Artifact
7d7e4242dbf45879567d35bc575bc02b98dacc49:
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 28 72 65 71 75 PURPOSE...(requ
0150: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
0160: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
0170: 63 70 20 73 31 31 6e 29 0a 0a 28 75 73 65 20 73 cp s11n)..(use s
0180: 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 rfi-1 posix rege
0190: 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 x regex-case srf
01a0: 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d 64 i-69 hostinfo md
01b0: 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 5 message-digest
01c0: 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 directory-utils
01d0: 20 70 6f 73 69 78 2d 65 78 74 72 61 73 20 6d 61 posix-extras ma
01e0: 74 63 68 61 62 6c 65 29 0a 3b 3b 20 28 75 73 65 tchable).;; (use
01f0: 20 7a 6d 71 29 0a 0a 28 75 73 65 20 73 70 69 66 zmq)..(use spif
0200: 66 79 20 75 72 69 2d 63 6f 6d 6d 6f 6e 20 69 6e fy uri-common in
0210: 74 61 72 77 65 62 20 68 74 74 70 2d 63 6c 69 65 tarweb http-clie
0220: 6e 74 20 73 70 69 66 66 79 2d 72 65 71 75 65 73 nt spiffy-reques
0230: 74 2d 76 61 72 73 29 0a 0a 28 64 65 63 6c 61 72 t-vars)..(declar
0240: 65 20 28 75 6e 69 74 20 73 65 72 76 65 72 29 29 e (unit server))
0250: 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ..(declare (uses
0260: 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 common)).(decla
0270: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0280: 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 61 73 eclare (uses tas
0290: 6b 73 29 29 20 3b 3b 20 74 61 73 6b 73 20 61 72 ks)) ;; tasks ar
02a0: 65 20 77 68 65 72 65 20 73 74 75 66 66 20 69 73 e where stuff is
02b0: 20 6d 61 69 6e 74 61 69 6e 65 64 20 61 62 6f 75 maintained abou
02c0: 74 20 77 68 61 74 20 69 73 20 72 75 6e 6e 69 6e t what is runnin
02d0: 67 2e 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 g..(declare (use
02e0: 73 20 73 79 6e 63 68 61 73 68 29 29 0a 28 64 65 s synchash)).(de
02f0: 63 6c 61 72 65 20 28 75 73 65 73 20 68 74 74 70 clare (uses http
0300: 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a 28 64 65 -transport)).(de
0310: 63 6c 61 72 65 20 28 75 73 65 73 20 72 70 63 2d clare (uses rpc-
0320: 74 72 61 6e 73 70 6f 72 74 29 29 0a 3b 3b 28 64 transport)).;;(d
0330: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6e 6d 73 eclare (uses nms
0340: 67 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a 28 64 g-transport)).(d
0350: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6c 61 75 eclare (uses lau
0360: 6e 63 68 29 29 0a 28 64 65 63 6c 61 72 65 20 28 nch)).(declare (
0370: 75 73 65 73 20 64 61 65 6d 6f 6e 29 29 0a 0a 28 uses daemon))..(
0380: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
0390: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
03a0: 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 nclude "db_recor
03b0: 64 73 2e 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e ds.scm")..(defin
03c0: 65 20 28 73 65 72 76 65 72 3a 6d 61 6b 65 2d 73 e (server:make-s
03d0: 65 72 76 65 72 2d 75 72 6c 20 68 6f 73 74 70 6f erver-url hostpo
03e0: 72 74 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 68 rt). (if (not h
03f0: 6f 73 74 70 6f 72 74 29 0a 20 20 20 20 20 20 23 ostport). #
0400: 66 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 22 68 f. (conc "h
0410: 74 74 70 3a 2f 2f 22 20 28 63 61 72 20 68 6f 73 ttp://" (car hos
0420: 74 70 6f 72 74 29 20 22 3a 22 20 28 63 61 64 72 tport) ":" (cadr
0430: 20 68 6f 73 74 70 6f 72 74 29 29 29 29 0a 0a 28 hostport))))..(
0440: 64 65 66 69 6e 65 20 20 2a 73 65 72 76 65 72 2d define *server-
0450: 6c 6f 6f 70 2d 68 65 61 72 74 2d 62 65 61 74 2a loop-heart-beat*
0460: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
0470: 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d s))..;;=========
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
04c0: 20 53 20 45 20 52 20 56 20 45 20 52 0a 3b 3b 3d S E R V E R.;;=
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 43 61 6c 6c 20 74 =====..;; Call t
0520: 68 69 73 20 74 6f 20 73 74 61 72 74 20 74 68 65 his to start the
0530: 20 61 63 74 75 61 6c 20 73 65 72 76 65 72 0a 3b actual server.;
0540: 3b 0a 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 ;..;; all routes
0550: 20 74 68 6f 75 67 68 20 68 65 72 65 20 65 6e 64 though here end
0560: 20 69 6e 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b 0a in exit ....;;.
0570: 3b 3b 20 73 74 61 72 74 5f 73 65 72 76 65 72 0a ;; start_server.
0580: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 ;;.(define (serv
0590: 65 72 3a 6c 61 75 6e 63 68 20 72 75 6e 2d 69 64 er:launch run-id
05a0: 20 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 29 transport-type)
05b0: 0a 20 20 28 63 61 73 65 20 74 72 61 6e 73 70 6f . (case transpo
05c0: 72 74 2d 74 79 70 65 0a 20 20 20 20 28 28 68 74 rt-type. ((ht
05d0: 74 70 29 28 68 74 74 70 2d 74 72 61 6e 73 70 6f tp)(http-transpo
05e0: 72 74 3a 6c 61 75 6e 63 68 29 29 0a 20 20 20 20 rt:launch)).
05f0: 3b 3b 28 28 6e 6d 73 67 29 28 6e 6d 73 67 2d 74 ;;((nmsg)(nmsg-t
0600: 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 ransport:launch
0610: 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 28 28 72 run-id)). ((r
0620: 70 63 29 20 20 28 72 70 63 2d 74 72 61 6e 73 70 pc) (rpc-transp
0630: 6f 72 74 3a 6c 61 75 6e 63 68 20 72 75 6e 2d 69 ort:launch run-i
0640: 64 29 29 0a 20 20 20 20 28 65 6c 73 65 20 28 64 d)). (else (d
0650: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
0660: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
0670: 70 6f 72 74 2a 20 22 75 6e 6b 6e 6f 77 6e 20 73 port* "unknown s
0680: 65 72 76 65 72 20 74 79 70 65 20 22 20 74 72 61 erver type " tra
0690: 6e 73 70 6f 72 74 2d 74 79 70 65 29 29 29 29 0a nsport-type)))).
06a0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
06b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 =========.;; S E
06f0: 20 52 20 56 20 45 20 52 20 20 20 55 20 54 20 49 R V E R U T I
0700: 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a 3b 3b L I T I E S .;;
0710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0750: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 20 74 ======..;; Get t
0760: 68 65 20 74 72 61 6e 73 70 6f 72 74 0a 28 64 65 he transport.(de
0770: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 fine (server:get
0780: 2d 74 72 61 6e 73 70 6f 72 74 29 0a 20 20 28 69 -transport). (i
0790: 66 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 f *transport-typ
07a0: 65 2a 0a 20 20 20 20 20 20 2a 74 72 61 6e 73 70 e*. *transp
07b0: 6f 72 74 2d 74 79 70 65 2a 0a 20 20 20 20 20 20 ort-type*.
07c0: 28 6c 65 74 20 28 28 74 74 79 70 65 20 28 73 74 (let ((ttype (st
07d0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 0a 09 09 20 ring->symbol...
07e0: 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 (or (args:get
07f0: 2d 61 72 67 20 22 2d 74 72 61 6e 73 70 6f 72 74 -arg "-transport
0800: 22 29 0a 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c ")....(configf:l
0810: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
0820: 2a 20 22 73 65 72 76 65 72 22 20 22 74 72 61 6e * "server" "tran
0830: 73 70 6f 72 74 22 29 0a 09 09 09 22 72 70 63 22 sport")...."rpc"
0840: 29 29 29 29 0a 09 28 73 65 74 21 20 2a 74 72 61 ))))..(set! *tra
0850: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 74 74 79 nsport-type* tty
0860: 70 65 29 0a 09 74 74 79 70 65 29 29 29 0a 09 20 pe)..ttype)))..
0870: 20 20 20 0a 3b 3b 20 47 65 6e 65 72 61 74 65 20 .;; Generate
0880: 61 20 75 6e 69 71 75 65 20 73 69 67 6e 61 74 75 a unique signatu
0890: 72 65 20 66 6f 72 20 74 68 69 73 20 73 65 72 76 re for this serv
08a0: 65 72 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 er.(define (serv
08b0: 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 er:mk-signature)
08c0: 0a 20 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 . (message-dige
08d0: 73 74 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 st-string (md5-p
08e0: 72 69 6d 69 74 69 76 65 29 20 0a 09 09 09 20 28 rimitive) .... (
08f0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 with-output-to-s
0900: 74 72 69 6e 67 0a 09 09 09 20 20 20 28 6c 61 6d tring.... (lam
0910: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 bda ().... (
0920: 77 72 69 74 65 20 28 6c 69 73 74 20 28 63 75 72 write (list (cur
0930: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 0a rent-directory).
0940: 09 09 09 09 09 20 20 28 61 72 67 76 29 29 29 29 ..... (argv))))
0950: 29 29 29 0a 0a 3b 3b 20 57 68 65 6e 20 75 73 69 )))..;; When usi
0960: 6e 67 20 7a 6d 71 20 74 68 69 73 20 77 6f 75 6c ng zmq this woul
0970: 64 20 73 65 6e 64 20 74 68 65 20 6d 65 73 73 61 d send the messa
0980: 67 65 20 62 61 63 6b 20 28 74 77 6f 20 73 74 65 ge back (two ste
0990: 70 20 70 72 6f 63 65 73 73 29 0a 3b 3b 20 77 69 p process).;; wi
09a0: 74 68 20 73 70 69 66 66 79 20 6f 72 20 72 70 63 th spiffy or rpc
09b0: 20 74 68 69 73 20 73 69 6d 70 6c 79 20 72 65 74 this simply ret
09c0: 75 72 6e 73 20 74 68 65 20 72 65 74 75 72 6e 20 urns the return
09d0: 64 61 74 61 20 74 6f 20 62 65 20 72 65 74 75 72 data to be retur
09e0: 6e 65 64 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 ned.;; .(define
09f0: 28 73 65 72 76 65 72 3a 72 65 70 6c 79 20 72 65 (server:reply re
0a00: 74 75 72 6e 2d 61 64 64 72 20 71 75 65 72 79 2d turn-addr query-
0a10: 73 69 67 20 73 75 63 63 65 73 73 2f 66 61 69 6c sig success/fail
0a20: 20 72 65 73 75 6c 74 29 0a 20 20 28 64 65 62 75 result). (debu
0a30: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 g:print-info 11
0a40: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0a50: 74 2a 20 22 73 65 72 76 65 72 3a 72 65 70 6c 79 t* "server:reply
0a60: 20 72 65 74 75 72 6e 2d 61 64 64 72 3d 22 20 72 return-addr=" r
0a70: 65 74 75 72 6e 2d 61 64 64 72 20 22 2c 20 72 65 eturn-addr ", re
0a80: 73 75 6c 74 3d 22 20 72 65 73 75 6c 74 29 0a 20 sult=" result).
0a90: 20 3b 3b 20 28 73 65 6e 64 2d 6d 65 73 73 61 67 ;; (send-messag
0aa0: 65 20 70 75 62 73 6f 63 6b 20 74 61 72 67 65 74 e pubsock target
0ab0: 20 73 65 6e 64 2d 6d 6f 72 65 3a 20 23 74 29 0a send-more: #t).
0ac0: 20 20 3b 3b 20 28 73 65 6e 64 2d 6d 65 73 73 61 ;; (send-messa
0ad0: 67 65 20 70 75 62 73 6f 63 6b 20 0a 20 20 28 63 ge pubsock . (c
0ae0: 61 73 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d ase (server:get-
0af0: 74 72 61 6e 73 70 6f 72 74 29 0a 20 20 20 20 28 transport). (
0b00: 28 72 70 63 29 20 20 28 64 62 3a 6f 62 6a 2d 3e (rpc) (db:obj->
0b10: 73 74 72 69 6e 67 20 28 76 65 63 74 6f 72 20 73 string (vector s
0b20: 75 63 63 65 73 73 2f 66 61 69 6c 20 71 75 65 72 uccess/fail quer
0b30: 79 2d 73 69 67 20 72 65 73 75 6c 74 29 29 29 0a y-sig result))).
0b40: 20 20 20 20 28 28 68 74 74 70 29 20 28 64 62 3a ((http) (db:
0b50: 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 28 76 65 63 obj->string (vec
0b60: 74 6f 72 20 73 75 63 63 65 73 73 2f 66 61 69 6c tor success/fail
0b70: 20 71 75 65 72 79 2d 73 69 67 20 72 65 73 75 6c query-sig resul
0b80: 74 29 29 29 0a 20 20 20 20 28 28 66 73 29 20 20 t))). ((fs)
0b90: 20 72 65 73 75 6c 74 29 0a 20 20 20 20 28 65 6c result). (el
0ba0: 73 65 20 0a 20 20 20 20 20 28 64 65 62 75 67 3a se . (debug:
0bb0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
0bc0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0bd0: 20 22 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 74 "unrecognised t
0be0: 72 61 6e 73 70 6f 72 74 20 74 79 70 65 3a 20 22 ransport type: "
0bf0: 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 *transport-type
0c00: 2a 29 0a 20 20 20 20 20 72 65 73 75 6c 74 29 29 *). result))
0c10: 29 0a 0a 3b 3b 20 47 69 76 65 6e 20 61 20 72 75 )..;; Given a ru
0c20: 6e 20 69 64 20 73 74 61 72 74 20 61 20 73 65 72 n id start a ser
0c30: 76 65 72 20 70 72 6f 63 65 73 73 20 20 20 20 23 ver process #
0c40: 23 23 20 4e 4f 54 45 20 23 23 23 20 3e 20 66 69 ## NOTE ### > fi
0c50: 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 69 66 20 74 le 2>&1 .;; if t
0c60: 68 65 20 72 75 6e 2d 69 64 20 69 73 20 7a 65 72 he run-id is zer
0c70: 6f 20 61 6e 64 20 74 68 65 20 74 61 72 67 65 74 o and the target
0c80: 2d 68 6f 73 74 20 69 73 20 73 65 74 20 0a 3b 3b -host is set .;;
0c90: 20 74 72 79 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 try running on
0ca0: 74 68 61 74 20 68 6f 73 74 0a 3b 3b 20 20 20 69 that host.;; i
0cb0: 6e 63 69 64 65 6e 74 61 6c 3a 20 72 6f 74 61 74 ncidental: rotat
0cc0: 65 20 6c 6f 67 73 20 69 6e 20 6c 6f 67 73 2f 20 e logs in logs/
0cd0: 64 69 72 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 dir..;;.(define
0ce0: 20 28 73 65 72 76 65 72 3a 72 75 6e 20 61 72 65 (server:run are
0cf0: 61 70 61 74 68 29 20 3b 3b 20 61 72 65 61 70 61 apath) ;; areapa
0d00: 74 68 20 69 73 20 2a 74 6f 70 70 61 74 68 2a 20 th is *toppath*
0d10: 66 6f 72 20 61 20 67 69 76 65 6e 20 74 65 73 74 for a given test
0d20: 73 75 69 74 65 20 61 72 65 61 0a 20 20 28 6c 65 suite area. (le
0d30: 74 2a 20 28 28 63 75 72 72 2d 68 6f 73 74 20 20 t* ((curr-host
0d40: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
0d50: 29 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 28 61 ). ;; (a
0d60: 74 74 65 6d 70 74 2d 69 6e 2d 70 72 6f 67 72 65 ttempt-in-progre
0d70: 73 73 20 28 73 65 72 76 65 72 3a 73 74 61 72 74 ss (server:start
0d80: 2d 61 74 74 65 6d 70 74 65 64 3f 20 61 72 65 61 -attempted? area
0d90: 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 path)).
0da0: 3b 3b 20 28 64 6f 74 2d 73 65 72 76 65 72 2d 75 ;; (dot-server-u
0db0: 72 6c 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b rl (server:check
0dc0: 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 -if-running area
0dd0: 70 61 74 68 29 29 0a 09 20 28 63 75 72 72 2d 69 path)).. (curr-i
0de0: 70 20 20 20 20 20 28 73 65 72 76 65 72 3a 67 65 p (server:ge
0df0: 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 t-best-guess-add
0e00: 72 65 73 73 20 63 75 72 72 2d 68 6f 73 74 29 29 ress curr-host))
0e10: 0a 09 20 28 63 75 72 72 2d 70 69 64 20 20 20 20 .. (curr-pid
0e20: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
0e30: 2d 69 64 29 29 0a 09 20 28 68 6f 6d 65 68 6f 73 -id)).. (homehos
0e40: 74 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 t (common:get
0e50: 2d 68 6f 6d 65 68 6f 73 74 29 29 20 3b 3b 20 63 -homehost)) ;; c
0e60: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
0e70: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 onfigdat* "serve
0e80: 72 22 20 22 68 6f 6d 65 68 6f 73 74 22 20 29 29 r" "homehost" ))
0e90: 0a 09 20 28 74 61 72 67 65 74 2d 68 6f 73 74 20 .. (target-host
0ea0: 28 63 61 72 20 68 6f 6d 65 68 6f 73 74 29 29 0a (car homehost)).
0eb0: 09 20 28 74 65 73 74 73 75 69 74 65 20 20 20 28 . (testsuite (
0ec0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 common:get-tests
0ed0: 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 20 28 6c uite-name)).. (l
0ee0: 6f 67 66 69 6c 65 20 20 20 20 20 28 63 6f 6e 63 ogfile (conc
0ef0: 20 61 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 areapath "/logs
0f00: 2f 73 65 72 76 65 72 2e 6c 6f 67 22 29 29 20 3b /server.log")) ;
0f10: 3b 20 2d 22 20 63 75 72 72 2d 70 69 64 20 22 2d ; -" curr-pid "-
0f20: 22 20 74 61 72 67 65 74 2d 68 6f 73 74 20 22 2e " target-host ".
0f30: 6c 6f 67 22 29 29 0a 09 20 28 63 6d 64 6c 6e 20 log")).. (cmdln
0f40: 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (conc (common:ge
0f50: 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 29 0a t-megatest-exe).
0f60: 09 09 20 20 20 20 20 20 22 20 2d 73 65 72 76 65 .. " -serve
0f70: 72 20 22 20 28 6f 72 20 74 61 72 67 65 74 2d 68 r " (or target-h
0f80: 6f 73 74 20 22 2d 22 29 20 28 69 66 20 28 65 71 ost "-") (if (eq
0f90: 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f ual? (configf:lo
0fa0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
0fb0: 20 22 73 65 72 76 65 72 22 20 22 64 61 65 6d 6f "server" "daemo
0fc0: 6e 69 7a 65 22 29 20 22 79 65 73 22 29 0a 09 09 nize") "yes")...
0fd0: 09 09 09 09 09 20 20 20 22 20 2d 64 61 65 6d 6f ..... " -daemo
0fe0: 6e 69 7a 65 20 22 0a 09 09 09 09 09 09 09 20 20 nize "........
0ff0: 20 22 22 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 "")... ;;
1000: 22 20 2d 6c 6f 67 20 22 20 6c 6f 67 66 69 6c 65 " -log " logfile
1010: 0a 09 09 20 20 20 20 20 20 22 20 2d 6d 20 74 65 ... " -m te
1020: 73 74 73 75 69 74 65 3a 22 20 74 65 73 74 73 75 stsuite:" testsu
1030: 69 74 65 29 29 20 3b 3b 20 28 63 6f 6e 63 20 22 ite)) ;; (conc "
1040: 20 3e 3e 20 22 20 6c 6f 67 66 69 6c 65 20 22 20 >> " logfile "
1050: 32 3e 26 31 20 26 22 29 29 29 29 29 0a 09 20 28 2>&1 &"))))).. (
1060: 6c 6f 67 2d 72 6f 74 61 74 65 20 20 28 6d 61 6b log-rotate (mak
1070: 65 2d 74 68 72 65 61 64 20 63 6f 6d 6d 6f 6e 3a e-thread common:
1080: 72 6f 74 61 74 65 2d 6c 6f 67 73 20 20 22 73 65 rotate-logs "se
1090: 72 76 65 72 20 72 75 6e 2c 20 72 6f 74 61 74 65 rver run, rotate
10a0: 20 6c 6f 67 73 20 74 68 72 65 61 64 22 29 29 29 logs thread")))
10b0: 0a 20 20 20 20 3b 3b 20 77 65 20 77 61 6e 74 20 . ;; we want
10c0: 74 68 65 20 72 65 6d 6f 74 65 20 73 65 72 76 65 the remote serve
10d0: 72 20 74 6f 20 73 74 61 72 74 20 69 6e 20 2a 74 r to start in *t
10e0: 6f 70 70 61 74 68 2a 20 73 6f 20 70 75 73 68 20 oppath* so push
10f0: 74 68 65 72 65 0a 20 20 20 20 28 70 75 73 68 2d there. (push-
1100: 64 69 72 65 63 74 6f 72 79 20 61 72 65 61 70 61 directory areapa
1110: 74 68 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 th). (debug:p
1120: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
1130: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
1140: 20 54 72 79 69 6e 67 20 74 6f 20 73 74 61 72 74 Trying to start
1150: 20 73 65 72 76 65 72 20 28 22 20 63 6d 64 6c 6e server (" cmdln
1160: 20 22 29 20 2e 2e 2e 22 29 0a 20 20 20 20 28 74 ") ..."). (t
1170: 68 72 65 61 64 2d 73 74 61 72 74 21 20 6c 6f 67 hread-start! log
1180: 2d 72 6f 74 61 74 65 29 0a 20 20 20 20 0a 20 20 -rotate). .
1190: 20 20 3b 3b 20 68 6f 73 74 2e 64 6f 6d 61 69 6e ;; host.domain
11a0: 2e 74 6c 64 20 6d 61 74 63 68 20 68 6f 73 74 3f .tld match host?
11b0: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 74 61 . (if (and ta
11c0: 72 67 65 74 2d 68 6f 73 74 20 0a 09 20 20 20 20 rget-host ..
11d0: 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 61 72 67 ;; look at targ
11e0: 65 74 20 68 6f 73 74 2c 20 69 73 20 69 74 20 68 et host, is it h
11f0: 6f 73 74 2e 64 6f 6d 61 69 6e 2e 74 6c 64 20 6f ost.domain.tld o
1200: 72 20 69 70 20 61 64 64 72 65 73 73 20 61 6e 64 r ip address and
1210: 20 64 6f 65 73 20 69 74 20 0a 09 20 20 20 20 20 does it ..
1220: 3b 3b 20 6d 61 74 63 68 20 63 75 72 72 65 6e 74 ;; match current
1230: 20 69 70 20 6f 72 20 68 6f 73 74 6e 61 6d 65 0a ip or hostname.
1240: 09 20 20 20 20 20 28 6e 6f 74 20 28 73 74 72 69 . (not (stri
1250: 6e 67 2d 6d 61 74 63 68 20 28 63 6f 6e 63 20 22 ng-match (conc "
1260: 28 22 63 75 72 72 2d 68 6f 73 74 20 22 7c 22 20 ("curr-host "|"
1270: 63 75 72 72 2d 68 6f 73 74 22 5c 5c 2e 2e 2a 29 curr-host"\\..*)
1280: 22 29 20 74 61 72 67 65 74 2d 68 6f 73 74 29 29 ") target-host))
1290: 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 .. (not (equ
12a0: 61 6c 3f 20 63 75 72 72 2d 69 70 20 74 61 72 67 al? curr-ip targ
12b0: 65 74 2d 68 6f 73 74 29 29 29 0a 09 28 62 65 67 et-host)))..(beg
12c0: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
12d0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
12e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 lt-log-port* "St
12f0: 61 72 74 69 6e 67 20 73 65 72 76 65 72 20 6f 6e arting server on
1300: 20 22 20 74 61 72 67 65 74 2d 68 6f 73 74 20 22 " target-host "
1310: 2c 20 6c 6f 67 66 69 6c 65 20 69 73 20 22 20 6c , logfile is " l
1320: 6f 67 66 69 6c 65 29 0a 09 20 20 28 73 65 74 65 ogfile).. (sete
1330: 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 20 nv "TARGETHOST"
1340: 74 61 72 67 65 74 2d 68 6f 73 74 29 29 29 0a 20 target-host))).
1350: 20 20 20 20 20 0a 20 20 20 20 28 73 65 74 65 6e . (seten
1360: 76 20 22 54 41 52 47 45 54 48 4f 53 54 5f 4c 4f v "TARGETHOST_LO
1370: 47 46 22 20 6c 6f 67 66 69 6c 65 29 0a 20 20 20 GF" logfile).
1380: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
1390: 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 6c 6f 61 r-normalized-loa
13a0: 64 20 34 20 22 20 64 65 6c 61 79 69 6e 67 20 73 d 4 " delaying s
13b0: 65 72 76 65 72 20 73 74 61 72 74 20 64 75 65 20 erver start due
13c0: 74 6f 20 6c 6f 61 64 22 20 72 65 6d 6f 74 65 2d to load" remote-
13d0: 68 6f 73 74 3a 20 28 67 65 74 2d 65 6e 76 69 72 host: (get-envir
13e0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
13f0: 22 54 41 52 47 45 54 48 4f 53 54 22 29 29 20 3b "TARGETHOST")) ;
1400: 3b 20 64 6f 20 6e 6f 74 20 74 72 79 20 73 74 61 ; do not try sta
1410: 72 74 69 6e 67 20 73 65 72 76 65 72 73 20 6f 6e rting servers on
1420: 20 61 6e 20 61 6c 72 65 61 64 79 20 6f 76 65 72 an already over
1430: 6c 6f 61 64 65 64 20 6d 61 63 68 69 6e 65 2c 20 loaded machine,
1440: 6a 75 73 74 20 77 61 69 74 20 66 6f 72 65 76 65 just wait foreve
1450: 72 0a 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 r. (system (c
1460: 6f 6e 63 20 22 6e 62 66 61 6b 65 20 22 20 63 6d onc "nbfake " cm
1470: 64 6c 6e 29 29 0a 20 20 20 20 28 75 6e 73 65 74 dln)). (unset
1480: 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 5f env "TARGETHOST_
1490: 4c 4f 47 46 22 29 0a 20 20 20 20 28 69 66 20 28 LOGF"). (if (
14a0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
14b0: 76 61 72 69 61 62 6c 65 20 22 54 41 52 47 45 54 variable "TARGET
14c0: 48 4f 53 54 22 29 28 75 6e 73 65 74 65 6e 76 20 HOST")(unsetenv
14d0: 22 54 41 52 47 45 54 48 4f 53 54 22 29 29 0a 20 "TARGETHOST")).
14e0: 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 (thread-join!
14f0: 20 6c 6f 67 2d 72 6f 74 61 74 65 29 0a 20 20 20 log-rotate).
1500: 20 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 79 29 (pop-directory)
1510: 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 20 70 ))..;; given a p
1520: 61 74 68 20 74 6f 20 61 20 73 65 72 76 65 72 20 ath to a server
1530: 6c 6f 67 20 72 65 74 75 72 6e 3a 20 68 6f 73 74 log return: host
1540: 20 70 6f 72 74 20 73 74 61 72 74 73 65 63 6f 6e port startsecon
1550: 64 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 ds.;;.(define (s
1560: 65 72 76 65 72 3a 6c 6f 67 66 2d 67 65 74 2d 73 erver:logf-get-s
1570: 74 61 72 74 2d 69 6e 66 6f 20 6c 6f 67 66 29 0a tart-info logf).
1580: 20 20 28 6c 65 74 20 28 28 72 78 20 28 72 65 67 (let ((rx (reg
1590: 65 78 70 20 22 5e 53 45 52 56 45 52 20 53 54 41 exp "^SERVER STA
15a0: 52 54 45 44 3a 20 28 5c 5c 53 2b 29 3a 28 5c 5c RTED: (\\S+):(\\
15b0: 64 2b 29 20 41 54 20 28 5b 5c 5c 64 5c 5c 2e 5d d+) AT ([\\d\\.]
15c0: 2b 29 22 29 29 29 20 3b 3b 20 53 45 52 56 45 52 +)"))) ;; SERVER
15d0: 20 53 54 41 52 54 45 44 3a 20 68 6f 73 74 3a 70 STARTED: host:p
15e0: 6f 72 74 20 41 54 20 74 69 6d 65 73 65 63 73 0a ort AT timesecs.
15f0: 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d (with-input-
1600: 66 72 6f 6d 2d 66 69 6c 65 0a 09 6c 6f 67 66 0a from-file..logf.
1610: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
1620: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e ..(let loop ((in
1630: 6c 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a l (read-line)).
1640: 09 09 20 20 20 28 6c 6e 75 6d 20 30 29 29 0a 09 .. (lnum 0))..
1650: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 6f 66 2d (if (not (eof-
1660: 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 29 0a 09 20 object? inl))..
1670: 20 20 20 20 20 28 6c 65 74 20 28 28 6d 6c 73 74 (let ((mlst
1680: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 (string-match r
1690: 78 20 69 6e 6c 29 29 29 0a 09 09 28 69 66 20 28 x inl)))...(if (
16a0: 6e 6f 74 20 6d 6c 73 74 29 0a 09 09 20 20 20 20 not mlst)...
16b0: 28 69 66 20 28 3c 20 6c 6e 75 6d 20 35 30 30 29 (if (< lnum 500)
16c0: 20 3b 3b 20 67 69 76 65 20 75 70 20 69 66 20 6d ;; give up if m
16d0: 6f 72 65 20 74 68 61 6e 20 35 30 30 20 6c 69 6e ore than 500 lin
16e0: 65 73 20 6f 66 20 73 65 72 76 65 72 20 6c 6f 67 es of server log
16f0: 20 72 65 61 64 0a 09 09 09 28 6c 6f 6f 70 20 28 read....(loop (
1700: 72 65 61 64 2d 6c 69 6e 65 29 28 2b 20 6c 6e 75 read-line)(+ lnu
1710: 6d 20 31 29 29 0a 09 09 09 28 6c 69 73 74 20 23 m 1))....(list #
1720: 66 20 23 66 20 23 66 29 29 0a 09 09 20 20 20 20 f #f #f))...
1730: 28 6c 65 74 20 28 28 64 61 74 20 20 28 63 64 72 (let ((dat (cdr
1740: 20 6d 6c 73 74 29 29 29 0a 09 09 20 20 20 20 20 mlst)))...
1750: 20 28 6c 69 73 74 20 28 63 61 72 20 64 61 74 29 (list (car dat)
1760: 20 3b 3b 20 68 6f 73 74 0a 09 09 09 20 20 20 20 ;; host....
1770: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
1780: 28 63 61 64 72 20 64 61 74 29 29 20 3b 3b 20 70 (cadr dat)) ;; p
1790: 6f 72 74 0a 09 09 09 20 20 20 20 28 73 74 72 69 ort.... (stri
17a0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 ng->number (cadd
17b0: 72 20 64 61 74 29 29 29 29 29 29 0a 09 20 20 20 r dat))))))..
17c0: 20 20 20 28 6c 69 73 74 20 23 66 20 23 66 20 23 (list #f #f #
17d0: 66 29 29 29 29 29 29 29 0a 0a 3b 3b 20 67 65 74 f)))))))..;; get
17e0: 20 61 20 6c 69 73 74 20 6f 66 20 73 65 72 76 65 a list of serve
17f0: 72 73 20 77 69 74 68 20 61 6c 6c 20 72 65 6c 65 rs with all rele
1800: 76 61 6e 74 20 64 61 74 61 0a 3b 3b 20 28 20 6d vant data.;; ( m
1810: 6f 64 2d 74 69 6d 65 20 68 6f 73 74 20 70 6f 72 od-time host por
1820: 74 20 73 74 61 72 74 2d 74 69 6d 65 20 70 69 64 t start-time pid
1830: 20 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 ).;;.(define (s
1840: 65 72 76 65 72 3a 67 65 74 2d 6c 69 73 74 20 61 erver:get-list a
1850: 72 65 61 70 61 74 68 20 23 21 6b 65 79 20 28 6c reapath #!key (l
1860: 69 6d 69 74 20 23 66 29 29 0a 20 20 28 6c 65 74 imit #f)). (let
1870: 20 28 28 66 6e 61 6d 65 2d 72 78 20 20 20 20 28 ((fname-rx (
1880: 72 65 67 65 78 70 20 22 5e 28 7c 2e 2a 2f 29 73 regexp "^(|.*/)s
1890: 65 72 76 65 72 2d 28 5c 5c 64 2b 29 2d 28 5c 5c erver-(\\d+)-(\\
18a0: 53 2b 29 2e 6c 6f 67 24 22 29 29 0a 09 28 64 61 S+).log$"))..(da
18b0: 79 2d 73 65 63 6f 6e 64 73 20 28 2a 20 32 34 20 y-seconds (* 24
18c0: 36 30 20 36 30 29 29 29 0a 20 20 20 20 3b 3b 20 60 60))). ;;
18d0: 69 66 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 if the directory
18e0: 20 65 78 69 73 74 73 20 63 6f 6e 74 69 6e 75 65 exists continue
18f0: 20 74 6f 20 67 65 74 20 74 68 65 20 6c 69 73 74 to get the list
1900: 0a 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 . ;; otherwis
1910: 65 20 61 74 74 65 6d 70 74 20 74 6f 20 63 72 65 e attempt to cre
1920: 61 74 65 20 74 68 65 20 6c 6f 67 73 20 64 69 72 ate the logs dir
1930: 20 61 6e 64 20 74 68 65 6e 0a 20 20 20 20 3b 3b and then. ;;
1940: 20 63 6f 6e 74 69 6e 75 65 0a 20 20 20 20 28 69 continue. (i
1950: 66 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 f (if (directory
1960: 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 61 -exists? (conc a
1970: 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 22 29 reapath "/logs")
1980: 29 0a 09 20 20 20 20 23 74 0a 09 20 20 20 20 28 ).. #t.. (
1990: 69 66 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 if (file-write-a
19a0: 63 63 65 73 73 3f 20 61 72 65 61 70 61 74 68 29 ccess? areapath)
19b0: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 63 ...(begin... (c
19c0: 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a 09 09 ondition-case...
19d0: 20 20 20 20 20 20 28 63 72 65 61 74 65 2d 64 69 (create-di
19e0: 72 65 63 74 6f 72 79 20 28 63 6f 6e 63 20 61 72 rectory (conc ar
19f0: 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 22 29 20 eapath "/logs")
1a00: 23 74 29 0a 09 09 20 20 20 20 28 65 78 6e 20 28 #t)... (exn (
1a10: 69 2f 6f 20 66 69 6c 65 29 28 64 65 62 75 67 3a i/o file)(debug:
1a20: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
1a30: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
1a40: 52 3a 20 43 61 6e 6e 6f 74 20 63 72 65 61 74 65 R: Cannot create
1a50: 20 64 69 72 65 63 74 6f 72 79 20 61 74 20 22 20 directory at "
1a60: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 (conc areapath "
1a70: 2f 6c 6f 67 73 22 29 29 29 0a 09 09 20 20 20 20 /logs")))...
1a80: 28 65 78 6e 20 28 29 28 64 65 62 75 67 3a 70 72 (exn ()(debug:pr
1a90: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
1aa0: 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
1ab0: 20 55 6e 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 61 Unknown error a
1ac0: 74 74 65 6d 74 70 69 6e 67 20 74 6f 20 67 65 74 ttemtping to get
1ad0: 20 73 65 72 76 65 72 20 6c 69 73 74 2e 22 29 29 server list."))
1ae0: 29 0a 09 09 20 20 28 64 69 72 65 63 74 6f 72 79 )... (directory
1af0: 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 61 -exists? (conc a
1b00: 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 22 29 reapath "/logs")
1b10: 29 29 0a 09 09 23 66 29 29 0a 09 28 6c 65 74 2a ))...#f))..(let*
1b20: 20 28 28 73 65 72 76 65 72 2d 6c 6f 67 73 20 20 ((server-logs
1b30: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 61 72 65 (glob (conc are
1b40: 61 70 61 74 68 20 22 2f 6c 6f 67 73 2f 73 65 72 apath "/logs/ser
1b50: 76 65 72 2d 2a 2e 6c 6f 67 22 29 29 29 0a 09 20 ver-*.log")))..
1b60: 20 20 20 20 20 20 28 6e 75 6d 2d 73 65 72 76 2d (num-serv-
1b70: 6c 6f 67 73 20 28 6c 65 6e 67 74 68 20 73 65 72 logs (length ser
1b80: 76 65 72 2d 6c 6f 67 73 29 29 29 0a 09 20 20 28 ver-logs))).. (
1b90: 69 66 20 28 6e 75 6c 6c 3f 20 73 65 72 76 65 72 if (null? server
1ba0: 2d 6c 6f 67 73 29 0a 09 20 20 20 20 20 20 27 28 -logs).. '(
1bb0: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ).. (let lo
1bc0: 6f 70 20 28 28 68 65 64 20 20 28 63 61 72 20 73 op ((hed (car s
1bd0: 65 72 76 65 72 2d 6c 6f 67 73 29 29 0a 09 09 09 erver-logs))....
1be0: 20 28 74 61 6c 20 20 28 63 64 72 20 73 65 72 76 (tal (cdr serv
1bf0: 65 72 2d 6c 6f 67 73 29 29 0a 09 09 09 20 28 72 er-logs)).... (r
1c00: 65 73 20 27 28 29 29 29 0a 09 09 28 6c 65 74 2a es '()))...(let*
1c10: 20 28 28 6d 6f 64 2d 74 69 6d 65 20 20 28 66 69 ((mod-time (fi
1c20: 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d le-modification-
1c30: 74 69 6d 65 20 68 65 64 29 29 0a 09 09 20 20 20 time hed))...
1c40: 20 20 20 20 28 64 6f 77 6e 2d 74 69 6d 65 20 28 (down-time (
1c50: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
1c60: 64 73 29 20 6d 6f 64 2d 74 69 6d 65 29 29 0a 09 ds) mod-time))..
1c70: 09 20 20 20 20 20 20 20 28 73 65 72 76 2d 64 61 . (serv-da
1c80: 74 20 20 28 69 66 20 28 6f 72 20 28 3c 20 6e 75 t (if (or (< nu
1c90: 6d 2d 73 65 72 76 2d 6c 6f 67 73 20 31 30 29 0a m-serv-logs 10).
1ca0: 09 09 09 09 20 20 09 20 20 28 3c 20 64 6f 77 6e .... . (< down
1cb0: 2d 74 69 6d 65 20 64 61 79 2d 73 65 63 6f 6e 64 -time day-second
1cc0: 73 29 29 0a 09 09 09 09 20 20 20 20 20 28 73 65 s))..... (se
1cd0: 72 76 65 72 3a 6c 6f 67 66 2d 67 65 74 2d 73 74 rver:logf-get-st
1ce0: 61 72 74 2d 69 6e 66 6f 20 68 65 64 29 0a 09 09 art-info hed)...
1cf0: 09 09 20 20 20 20 20 27 28 29 29 29 20 3b 3b 20 .. '())) ;;
1d00: 64 6f 6e 27 74 20 77 61 73 74 65 20 74 69 6d 65 don't waste time
1d10: 20 70 72 6f 63 65 73 73 69 6e 67 20 73 65 72 76 processing serv
1d20: 65 72 20 66 69 6c 65 73 20 6e 6f 74 20 74 6f 75 er files not tou
1d30: 63 68 65 64 20 69 6e 20 74 68 65 20 70 61 73 74 ched in the past
1d40: 20 64 61 79 20 69 66 20 74 68 65 72 65 20 61 72 day if there ar
1d50: 65 20 6d 6f 72 65 20 74 68 61 6e 20 74 65 6e 20 e more than ten
1d60: 73 65 72 76 65 72 73 20 74 6f 20 6c 6f 6f 6b 20 servers to look
1d70: 61 74 0a 09 09 20 20 20 20 20 20 20 28 73 65 72 at... (ser
1d80: 76 2d 72 65 63 20 28 63 6f 6e 73 20 6d 6f 64 2d v-rec (cons mod-
1d90: 74 69 6d 65 20 73 65 72 76 2d 64 61 74 29 29 0a time serv-dat)).
1da0: 09 09 20 20 20 20 20 20 20 28 66 6d 61 74 63 68 .. (fmatch
1db0: 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 (string-match
1dc0: 20 66 6e 61 6d 65 2d 72 78 20 68 65 64 29 29 0a fname-rx hed)).
1dd0: 09 09 20 20 20 20 20 20 20 28 70 69 64 20 20 20 .. (pid
1de0: 20 20 20 28 69 66 20 66 6d 61 74 63 68 20 28 73 (if fmatch (s
1df0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6c tring->number (l
1e00: 69 73 74 2d 72 65 66 20 66 6d 61 74 63 68 20 32 ist-ref fmatch 2
1e10: 29 29 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 )) #f))...
1e20: 20 28 6e 65 77 2d 72 65 73 20 20 28 69 66 20 28 (new-res (if (
1e30: 6e 75 6c 6c 3f 20 73 65 72 76 2d 64 61 74 29 0a null? serv-dat).
1e40: 09 09 09 09 20 20 20 20 20 72 65 73 0a 09 09 09 .... res....
1e50: 09 20 20 20 20 20 28 63 6f 6e 73 20 28 61 70 70 . (cons (app
1e60: 65 6e 64 20 73 65 72 76 2d 72 65 63 20 28 6c 69 end serv-rec (li
1e70: 73 74 20 70 69 64 29 29 20 72 65 73 29 29 29 29 st pid)) res))))
1e80: 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 ...(if (null? ta
1e90: 6c 29 0a 09 09 20 20 20 20 28 69 66 20 28 61 6e l)... (if (an
1ea0: 64 20 6c 69 6d 69 74 0a 09 09 09 20 20 20 20 20 d limit....
1eb0: 28 3e 20 28 6c 65 6e 67 74 68 20 6e 65 77 2d 72 (> (length new-r
1ec0: 65 73 29 20 6c 69 6d 69 74 29 29 0a 09 09 09 6e es) limit))....n
1ed0: 65 77 2d 72 65 73 20 3b 3b 20 28 74 61 6b 65 20 ew-res ;; (take
1ee0: 6e 65 77 2d 72 65 73 20 6c 69 6d 69 74 29 20 20 new-res limit)
1ef0: 3c 3d 20 6e 65 65 64 20 69 6e 74 65 6c 6c 69 67 <= need intellig
1f00: 65 6e 74 20 73 6f 72 74 69 6e 67 20 62 65 66 6f ent sorting befo
1f10: 72 65 20 74 68 69 73 20 77 69 6c 6c 20 77 6f 72 re this will wor
1f20: 6b 0a 09 09 09 6e 65 77 2d 72 65 73 29 0a 09 09 k....new-res)...
1f30: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
1f40: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e tal)(cdr tal) n
1f50: 65 77 2d 72 65 73 29 29 29 29 29 29 29 29 29 0a ew-res))))))))).
1f60: 0a 3b 3b 20 67 69 76 65 6e 20 61 20 6c 69 73 74 .;; given a list
1f70: 20 6f 66 20 73 65 72 76 65 72 73 20 67 65 74 20 of servers get
1f80: 61 20 6c 69 73 74 20 6f 66 20 76 61 6c 69 64 20 a list of valid
1f90: 73 65 72 76 65 72 73 2c 20 69 2e 65 2e 20 61 74 servers, i.e. at
1fa0: 20 6c 65 61 73 74 0a 3b 3b 20 31 30 20 73 65 63 least.;; 10 sec
1fb0: 6f 6e 64 73 20 6f 6c 64 2c 20 68 61 73 20 73 74 onds old, has st
1fc0: 61 72 74 65 64 20 61 6e 64 20 69 73 20 6c 65 73 arted and is les
1fd0: 73 20 74 68 61 6e 20 31 20 68 6f 75 72 20 6f 6c s than 1 hour ol
1fe0: 64 20 61 6e 64 20 69 73 0a 3b 3b 20 61 63 74 69 d and is.;; acti
1ff0: 76 65 20 28 69 2e 65 2e 20 6d 6f 64 2d 74 69 6d ve (i.e. mod-tim
2000: 65 20 3c 20 31 30 20 73 65 63 6f 6e 64 73 0a 3b e < 10 seconds.;
2010: 3b 0a 3b 3b 20 6d 6f 64 2d 74 69 6d 65 20 68 6f ;.;; mod-time ho
2020: 73 74 20 70 6f 72 74 20 73 74 61 72 74 2d 74 69 st port start-ti
2030: 6d 65 20 70 69 64 0a 3b 3b 0a 3b 3b 20 73 6f 72 me pid.;;.;; sor
2040: 74 20 62 79 20 73 74 61 72 74 2d 74 69 6d 65 20 t by start-time
2050: 64 65 73 63 65 6e 64 69 6e 67 2e 20 49 2e 65 2e descending. I.e.
2060: 20 67 65 74 20 74 68 65 20 6f 6c 64 65 73 74 20 get the oldest
2070: 66 69 72 73 74 2e 20 59 6f 75 6e 67 20 73 65 72 first. Young ser
2080: 76 65 72 73 20 77 69 6c 6c 20 74 68 75 73 20 64 vers will thus d
2090: 72 6f 70 20 6f 66 66 0a 3b 3b 20 61 6e 64 20 73 rop off.;; and s
20a0: 65 72 76 65 72 73 20 73 68 6f 75 6c 64 20 73 74 ervers should st
20b0: 69 63 6b 20 61 72 6f 75 6e 64 20 66 6f 72 20 61 ick around for a
20c0: 62 6f 75 74 20 74 77 6f 20 68 6f 75 72 73 20 6f bout two hours o
20d0: 72 20 73 6f 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 r so..;;.(define
20e0: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 (server:get-bes
20f0: 74 20 73 72 76 6c 73 74 29 0a 20 20 28 6c 65 74 t srvlst). (let
2100: 20 28 28 6e 6f 77 20 28 63 75 72 72 65 6e 74 2d ((now (current-
2110: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 seconds))). (
2120: 73 6f 72 74 0a 20 20 20 20 20 28 66 69 6c 74 65 sort. (filte
2130: 72 20 28 6c 61 6d 62 64 61 20 28 72 65 63 29 0a r (lambda (rec).
2140: 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 . (let ((s
2150: 74 61 72 74 2d 74 69 6d 65 20 28 6c 69 73 74 2d tart-time (list-
2160: 72 65 66 20 72 65 63 20 33 29 29 0a 09 09 20 20 ref rec 3))...
2170: 20 20 20 28 6d 6f 64 2d 74 69 6d 65 20 20 20 28 (mod-time (
2180: 6c 69 73 74 2d 72 65 66 20 72 65 63 20 30 29 29 list-ref rec 0))
2190: 29 0a 09 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 )... ;; (print "
21a0: 73 74 61 72 74 2d 74 69 6d 65 3a 20 22 20 73 74 start-time: " st
21b0: 61 72 74 2d 74 69 6d 65 20 22 20 6d 6f 64 2d 74 art-time " mod-t
21c0: 69 6d 65 3a 20 22 20 6d 6f 64 2d 74 69 6d 65 29 ime: " mod-time)
21d0: 0a 09 09 20 28 61 6e 64 20 73 74 61 72 74 2d 74 ... (and start-t
21e0: 69 6d 65 20 6d 6f 64 2d 74 69 6d 65 0a 09 09 20 ime mod-time...
21f0: 20 20 20 20 20 28 3e 20 28 2d 20 6e 6f 77 20 73 (> (- now s
2200: 74 61 72 74 2d 74 69 6d 65 29 20 30 29 20 20 20 tart-time) 0)
2210: 20 3b 3b 20 62 65 65 6e 20 72 75 6e 6e 69 6e 67 ;; been running
2220: 20 61 74 20 6c 65 61 73 74 20 30 20 73 65 63 6f at least 0 seco
2230: 6e 64 73 0a 09 09 20 20 20 20 20 20 28 3c 20 28 nds... (< (
2240: 2d 20 6e 6f 77 20 6d 6f 64 2d 74 69 6d 65 29 20 - now mod-time)
2250: 20 20 31 36 29 20 20 20 3b 3b 20 73 74 69 6c 6c 16) ;; still
2260: 20 61 6c 69 76 65 20 2d 20 66 69 6c 65 20 74 6f alive - file to
2270: 75 63 68 65 64 20 69 6e 20 6c 61 73 74 20 31 36 uched in last 16
2280: 20 73 65 63 6f 6e 64 73 0a 09 09 20 20 20 20 20 seconds...
2290: 20 28 3c 20 28 2d 20 6e 6f 77 20 73 74 61 72 74 (< (- now start
22a0: 2d 74 69 6d 65 29 20 0a 20 20 20 20 20 20 20 20 -time) .
22b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22c0: 20 28 2b 20 28 2d 20 28 73 74 72 69 6e 67 2d 3e (+ (- (string->
22d0: 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 number (or (conf
22e0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
22f0: 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 igdat* "server"
2300: 22 72 75 6e 74 69 6d 65 22 29 20 22 33 36 30 30 "runtime") "3600
2310: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
2320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2330: 20 20 20 31 38 30 29 0a 20 20 20 20 20 20 20 20 180).
2340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2350: 20 20 20 20 28 72 61 6e 64 6f 6d 20 33 36 30 29 (random 360)
2360: 29 29 20 3b 3b 20 75 6e 64 65 72 20 6f 6e 65 20 )) ;; under one
2370: 68 6f 75 72 20 72 75 6e 6e 69 6e 67 20 74 69 6d hour running tim
2380: 65 20 2b 2f 2d 20 31 38 30 0a 09 09 20 20 20 20 e +/- 180...
2390: 20 20 29 29 29 0a 09 20 20 20 20 20 73 72 76 6c ))).. srvl
23a0: 73 74 29 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 st). (lambda
23b0: 20 28 61 20 62 29 0a 20 20 20 20 20 20 20 28 3c (a b). (<
23c0: 20 28 6c 69 73 74 2d 72 65 66 20 61 20 33 29 0a (list-ref a 3).
23d0: 09 20 20 28 6c 69 73 74 2d 72 65 66 20 62 20 33 . (list-ref b 3
23e0: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
23f0: 28 73 65 72 76 65 72 3a 67 65 74 2d 66 69 72 73 (server:get-firs
2400: 74 2d 62 65 73 74 20 61 72 65 61 70 61 74 68 29 t-best areapath)
2410: 0a 20 20 28 6c 65 74 20 28 28 73 72 76 72 73 20 . (let ((srvrs
2420: 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 (server:get-best
2430: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6c 69 73 (server:get-lis
2440: 74 20 61 72 65 61 70 61 74 68 29 29 29 29 0a 20 t areapath)))).
2450: 20 20 20 28 69 66 20 28 61 6e 64 20 73 72 76 72 (if (and srvr
2460: 73 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 s.. (not (nu
2470: 6c 6c 3f 20 73 72 76 72 73 29 29 29 0a 09 28 63 ll? srvrs)))..(c
2480: 61 72 20 73 72 76 72 73 29 0a 09 23 66 29 29 29 ar srvrs)..#f)))
2490: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 ..(define (serve
24a0: 72 3a 72 65 63 6f 72 64 2d 3e 75 72 6c 20 73 65 r:record->url se
24b0: 72 76 72 29 0a 20 20 28 6d 61 74 63 68 2d 6c 65 rvr). (match-le
24c0: 74 20 28 28 28 6d 6f 64 2d 74 69 6d 65 20 68 6f t (((mod-time ho
24d0: 73 74 20 70 6f 72 74 20 73 74 61 72 74 2d 74 69 st port start-ti
24e0: 6d 65 20 70 69 64 29 0a 09 20 20 20 20 20 20 20 me pid)..
24f0: 73 65 72 76 72 29 29 0a 20 20 20 20 28 69 66 20 servr)). (if
2500: 28 61 6e 64 20 68 6f 73 74 20 70 6f 72 74 29 0a (and host port).
2510: 09 28 63 6f 6e 63 20 68 6f 73 74 20 22 3a 22 20 .(conc host ":"
2520: 70 6f 72 74 29 0a 09 23 66 29 29 29 0a 0a 28 64 port)..#f)))..(d
2530: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 efine (server:ge
2540: 74 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 t-client-signatu
2550: 72 65 29 20 3b 3b 20 42 42 3e 20 77 68 79 20 69 re) ;; BB> why i
2560: 73 20 74 68 69 73 20 70 72 6f 63 20 6e 61 6d 65 s this proc name
2570: 64 20 22 67 65 74 2d 22 3f 20 20 69 74 20 72 65 d "get-"? it re
2580: 74 75 72 6e 73 20 6e 6f 74 68 69 6e 67 20 2d 2d turns nothing --
2590: 20 73 65 74 21 20 68 61 73 20 6e 6f 74 20 72 65 set! has not re
25a0: 74 75 72 6e 20 76 61 6c 75 65 2e 0a 20 20 28 69 turn value.. (i
25b0: 66 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 f *my-client-sig
25c0: 6e 61 74 75 72 65 2a 20 2a 6d 79 2d 63 6c 69 65 nature* *my-clie
25d0: 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 0a 20 20 nt-signature*.
25e0: 20 20 20 20 28 6c 65 74 20 28 28 73 69 67 20 28 (let ((sig (
25f0: 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 server:mk-signat
2600: 75 72 65 29 29 29 0a 20 20 20 20 20 20 20 20 28 ure))). (
2610: 73 65 74 21 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d set! *my-client-
2620: 73 69 67 6e 61 74 75 72 65 2a 20 73 69 67 29 0a signature* sig).
2630: 20 20 20 20 20 20 20 20 2a 6d 79 2d 63 6c 69 65 *my-clie
2640: 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 29 29 nt-signature*)))
2650: 0a 0a 3b 3b 20 6b 69 6e 64 20 73 74 61 72 74 20 ..;; kind start
2660: 75 70 20 6f 66 20 73 65 72 76 65 72 73 2c 20 77 up of servers, w
2670: 61 69 74 20 34 30 20 73 65 63 6f 6e 64 73 20 62 ait 40 seconds b
2680: 65 66 6f 72 65 20 61 6c 6c 6f 77 69 6e 67 20 61 efore allowing a
2690: 6e 6f 74 68 65 72 20 73 65 72 76 65 72 20 66 6f nother server fo
26a0: 72 20 61 20 67 69 76 65 6e 0a 3b 3b 20 72 75 6e r a given.;; run
26b0: 2d 69 64 20 74 6f 20 62 65 20 6c 61 75 6e 63 68 -id to be launch
26c0: 65 64 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 ed.(define (serv
26d0: 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 61 72 65 61 er:kind-run area
26e0: 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 path). (let* ((
26f0: 6c 61 73 74 2d 72 75 6e 2d 64 61 74 20 28 68 61 last-run-dat (ha
2700: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
2710: 61 75 6c 74 20 2a 73 65 72 76 65 72 2d 6b 69 6e ault *server-kin
2720: 64 2d 72 75 6e 2a 20 61 72 65 61 70 61 74 68 20 d-run* areapath
2730: 27 28 30 20 30 29 29 29 20 3b 3b 20 63 61 6c 6c '(0 0))) ;; call
2740: 6e 75 6d 2c 20 77 68 65 6e 72 75 6e 0a 20 20 20 num, whenrun.
2750: 20 20 20 20 20 20 28 63 61 6c 6c 2d 6e 75 6d 20 (call-num
2760: 20 20 20 20 28 63 61 72 20 6c 61 73 74 2d 72 75 (car last-ru
2770: 6e 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 n-dat)).
2780: 20 28 77 68 65 6e 2d 72 75 6e 20 20 20 20 20 28 (when-run (
2790: 63 61 64 72 20 6c 61 73 74 2d 72 75 6e 2d 64 61 cadr last-run-da
27a0: 74 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 75 t)). (ru
27b0: 6e 2d 64 65 6c 61 79 20 20 20 20 28 2b 20 28 63 n-delay (+ (c
27c0: 61 73 65 20 63 61 6c 6c 2d 6e 75 6d 0a 20 20 20 ase call-num.
27d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27e0: 20 20 20 20 20 20 20 20 20 28 28 30 29 20 20 20 ((0)
27f0: 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0).
2800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2810: 28 28 31 29 20 20 20 32 30 29 0a 20 20 20 20 20 ((1) 20).
2820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2830: 20 20 20 20 20 20 20 28 28 32 29 20 20 33 30 30 ((2) 300
2840: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
2860: 6c 73 65 20 36 30 30 29 29 0a 20 20 20 20 20 20 lse 600)).
2870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2880: 20 20 20 20 28 72 61 6e 64 6f 6d 20 35 29 29 29 (random 5)))
2890: 29 20 3b 3b 20 61 64 64 20 61 20 73 6d 61 6c 6c ) ;; add a small
28a0: 20 72 61 6e 64 6f 6d 20 6e 75 6d 62 65 72 20 6a random number j
28b0: 75 73 74 20 69 6e 20 63 61 73 65 20 61 20 6c 6f ust in case a lo
28c0: 74 20 6f 66 20 6a 6f 62 73 20 68 69 74 20 74 68 t of jobs hit th
28d0: 65 20 77 6f 72 6b 20 68 6f 73 74 73 20 73 69 6d e work hosts sim
28e0: 75 6c 74 61 6e 65 6f 75 73 6c 79 0a 20 20 20 20 ultaneously.
28f0: 28 69 66 09 28 3e 20 28 2d 20 28 63 75 72 72 65 (if.(> (- (curre
2900: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 77 68 65 6e nt-seconds) when
2910: 2d 72 75 6e 29 20 72 75 6e 2d 64 65 6c 61 79 29 -run) run-delay)
2920: 0a 20 20 20 20 20 20 20 20 28 73 65 72 76 65 72 . (server
2930: 3a 72 75 6e 20 61 72 65 61 70 61 74 68 29 29 0a :run areapath)).
2940: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
2950: 73 65 74 21 20 2a 73 65 72 76 65 72 2d 6b 69 6e set! *server-kin
2960: 64 2d 72 75 6e 2a 20 61 72 65 61 70 61 74 68 20 d-run* areapath
2970: 28 6c 69 73 74 20 28 2b 20 63 61 6c 6c 2d 6e 75 (list (+ call-nu
2980: 6d 20 31 29 28 63 75 72 72 65 6e 74 2d 73 65 63 m 1)(current-sec
2990: 6f 6e 64 73 29 29 29 29 29 0a 0a 28 64 65 66 69 onds)))))..(defi
29a0: 6e 65 20 28 73 65 72 76 65 72 3a 73 74 61 72 74 ne (server:start
29b0: 2d 61 6e 64 2d 77 61 69 74 20 61 72 65 61 70 61 -and-wait areapa
29c0: 74 68 20 23 21 6b 65 79 20 28 74 69 6d 65 6f 75 th #!key (timeou
29d0: 74 20 36 30 29 29 0a 20 20 28 6c 65 74 20 28 28 t 60)). (let ((
29e0: 67 69 76 65 2d 75 70 2d 74 69 6d 65 20 28 2b 20 give-up-time (+
29f0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2a00: 29 20 74 69 6d 65 6f 75 74 29 29 29 0a 20 20 20 ) timeout))).
2a10: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 65 72 (let loop ((ser
2a20: 76 65 72 2d 75 72 6c 20 28 73 65 72 76 65 72 3a ver-url (server:
2a30: 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 check-if-running
2a40: 20 61 72 65 61 70 61 74 68 29 29 29 0a 20 20 20 areapath))).
2a50: 20 20 20 28 69 66 20 28 6f 72 20 73 65 72 76 65 (if (or serve
2a60: 72 2d 75 72 6c 0a 09 20 20 20 20 20 20 28 3e 20 r-url.. (>
2a70: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2a80: 29 20 67 69 76 65 2d 75 70 2d 74 69 6d 65 29 29 ) give-up-time))
2a90: 20 3b 3b 20 73 65 72 76 65 72 2d 75 72 6c 20 77 ;; server-url w
2aa0: 69 6c 6c 20 62 65 20 23 66 20 69 66 20 6e 6f 20 ill be #f if no
2ab0: 73 65 72 76 65 72 20 61 76 61 69 6c 61 62 6c 65 server available
2ac0: 2e 0a 09 20 20 73 65 72 76 65 72 2d 75 72 6c 0a ... server-url.
2ad0: 09 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 6f 6b . (let ((num-ok
2ae0: 20 28 6c 65 6e 67 74 68 20 28 73 65 72 76 65 72 (length (server
2af0: 3a 67 65 74 2d 62 65 73 74 20 28 73 65 72 76 65 :get-best (serve
2b00: 72 3a 67 65 74 2d 6c 69 73 74 20 61 72 65 61 70 r:get-list areap
2b10: 61 74 68 29 29 29 29 29 0a 09 20 20 20 20 28 69 ath))))).. (i
2b20: 66 20 28 3c 20 6e 75 6d 2d 6f 6b 20 31 29 20 3b f (< num-ok 1) ;
2b30: 3b 20 69 66 20 74 68 65 72 65 20 61 72 65 20 6e ; if there are n
2b40: 6f 20 64 65 63 65 6e 74 20 63 61 6e 64 69 64 61 o decent candida
2b50: 74 65 73 20 66 6f 72 20 73 65 72 76 65 72 73 20 tes for servers
2b60: 74 68 65 6e 20 74 72 79 20 73 74 61 72 74 69 6e then try startin
2b70: 67 20 61 20 6e 65 77 20 6f 6e 65 0a 09 09 28 73 g a new one...(s
2b80: 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 61 erver:kind-run a
2b90: 72 65 61 70 61 74 68 29 29 0a 09 20 20 20 20 28 reapath)).. (
2ba0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 thread-sleep! 5)
2bb0: 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 73 65 72 .. (loop (ser
2bc0: 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e ver:check-if-run
2bd0: 6e 69 6e 67 20 61 72 65 61 70 61 74 68 29 29 29 ning areapath)))
2be0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 65 ))))..(define se
2bf0: 72 76 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e 67 rver:try-running
2c00: 20 73 65 72 76 65 72 3a 72 75 6e 29 20 3b 3b 20 server:run) ;;
2c10: 74 68 65 72 65 20 69 73 20 6e 6f 20 6d 6f 72 65 there is no more
2c20: 20 70 65 72 2d 72 75 6e 20 73 65 72 76 65 72 73 per-run servers
2c30: 20 3b 3b 20 52 45 4d 4f 56 45 20 4d 45 2e 20 42 ;; REMOVE ME. B
2c40: 55 47 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 UG...(define (se
2c50: 72 76 65 72 3a 64 6f 74 73 65 72 76 65 72 2d 61 rver:dotserver-a
2c60: 67 65 2d 73 65 63 6f 6e 64 73 20 61 72 65 61 70 ge-seconds areap
2c70: 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 73 65 ath). (let ((se
2c80: 72 76 65 72 2d 66 69 6c 65 20 28 63 6f 6e 63 20 rver-file (conc
2c90: 61 72 65 61 70 61 74 68 20 22 2f 2e 73 65 72 76 areapath "/.serv
2ca0: 65 72 22 29 29 29 0a 20 20 20 20 28 62 65 67 69 er"))). (begi
2cb0: 6e 0a 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d n. (handle-
2cc0: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
2cd0: 20 20 65 78 6e 0a 20 20 20 20 20 20 20 23 66 0a exn. #f.
2ce0: 20 20 20 20 20 20 20 28 2d 20 28 63 75 72 72 65 (- (curre
2cf0: 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 20 20 nt-seconds).
2d00: 20 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 (file-modi
2d10: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 65 fication-time se
2d20: 72 76 65 72 2d 66 69 6c 65 29 29 29 29 29 29 0a rver-file)))))).
2d30: 20 20 20 20 0a 3b 3b 20 6e 6f 20 6c 6f 6e 67 65 .;; no longe
2d40: 72 20 63 61 72 65 20 69 66 20 6d 75 6c 74 69 70 r care if multip
2d50: 6c 65 20 73 65 72 76 65 72 73 20 61 72 65 20 73 le servers are s
2d60: 74 61 72 74 65 64 20 62 79 20 61 63 63 69 64 65 tarted by accide
2d70: 6e 74 2e 20 6f 6c 64 65 72 20 73 65 72 76 65 72 nt. older server
2d80: 73 20 77 69 6c 6c 20 64 72 6f 70 20 6f 66 66 20 s will drop off
2d90: 69 6e 20 74 69 6d 65 2e 0a 3b 3b 0a 28 64 65 66 in time..;;.(def
2da0: 69 6e 65 20 28 73 65 72 76 65 72 3a 63 68 65 63 ine (server:chec
2db0: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 k-if-running are
2dc0: 61 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 apath). (let* (
2dd0: 28 73 65 72 76 65 72 73 20 20 20 20 20 20 20 28 (servers (
2de0: 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 20 server:get-best
2df0: 28 73 65 72 76 65 72 3a 67 65 74 2d 6c 69 73 74 (server:get-list
2e00: 20 61 72 65 61 70 61 74 68 29 29 29 29 0a 20 20 areapath)))).
2e10: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 73 65 72 (if (null? ser
2e20: 76 65 72 73 29 0a 20 20 20 20 20 20 20 20 23 66 vers). #f
2e30: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f . (let lo
2e40: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 73 65 op ((hed (car se
2e50: 72 76 65 72 73 29 29 0a 20 20 20 20 20 20 20 20 rvers)).
2e60: 20 20 20 20 20 20 20 20 20 20 20 28 74 61 6c 20 (tal
2e70: 28 63 64 72 20 73 65 72 76 65 72 73 29 29 29 0a (cdr servers))).
2e80: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
2e90: 28 72 65 73 20 28 73 65 72 76 65 72 3a 63 68 65 (res (server:che
2ea0: 63 6b 2d 73 65 72 76 65 72 20 68 65 64 29 29 29 ck-server hed)))
2eb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 . (if
2ec0: 20 72 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 res.
2ed0: 20 20 20 20 20 72 65 73 0a 20 20 20 20 20 20 20 res.
2ee0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
2ef0: 6c 6c 3f 20 74 61 6c 29 0a 20 20 20 20 20 20 20 ll? tal).
2f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 0a #f.
2f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f20: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
2f30: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
2f40: 29 29 29 29 0a 0a 3b 3b 20 70 69 6e 67 20 74 68 ))))..;; ping th
2f50: 65 20 67 69 76 65 6e 20 73 65 72 76 65 72 0a 3b e given server.;
2f60: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 ;.(define (serve
2f70: 72 3a 63 68 65 63 6b 2d 73 65 72 76 65 72 20 73 r:check-server s
2f80: 65 72 76 65 72 2d 72 65 63 6f 72 64 29 0a 20 20 erver-record).
2f90: 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 75 (let* ((server-u
2fa0: 72 6c 20 28 73 65 72 76 65 72 3a 72 65 63 6f 72 rl (server:recor
2fb0: 64 2d 3e 75 72 6c 20 73 65 72 76 65 72 2d 72 65 d->url server-re
2fc0: 63 6f 72 64 29 29 0a 20 20 20 20 20 20 20 20 20 cord)).
2fd0: 28 72 65 73 20 20 20 20 20 20 20 20 28 63 61 73 (res (cas
2fe0: 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 e *transport-typ
2ff0: 65 2a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e*.
3000: 20 20 20 20 20 20 20 20 20 20 28 28 68 74 74 70 ((http
3010: 29 28 73 65 72 76 65 72 3a 70 69 6e 67 20 73 65 )(server:ping se
3020: 72 76 65 72 2d 75 72 6c 29 29 0a 20 20 20 20 20 rver-url)).
3030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3040: 20 20 3b 3b 20 28 28 6e 6d 73 67 29 28 6e 6d 73 ;; ((nmsg)(nms
3050: 67 2d 74 72 61 6e 73 70 6f 72 74 3a 70 69 6e 67 g-transport:ping
3060: 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f (tasks:hostinfo
3070: 2d 67 65 74 2d 69 6e 74 65 72 66 61 63 65 20 73 -get-interface s
3080: 65 72 76 65 72 29 0a 20 20 20 20 20 20 20 20 20 erver).
3090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 ))
30a0: 29 0a 20 20 20 20 28 69 66 20 72 65 73 0a 20 20 ). (if res.
30b0: 20 20 20 20 20 20 73 65 72 76 65 72 2d 75 72 6c server-url
30c0: 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 ..#f)))..(define
30d0: 20 28 73 65 72 76 65 72 3a 6b 69 6c 6c 20 73 65 (server:kill se
30e0: 72 76 72 29 0a 20 20 28 6d 61 74 63 68 2d 6c 65 rvr). (match-le
30f0: 74 20 28 28 28 6d 6f 64 2d 74 69 6d 65 20 68 6f t (((mod-time ho
3100: 73 74 6e 61 6d 65 20 70 6f 72 74 20 73 74 61 72 stname port star
3110: 74 2d 74 69 6d 65 20 70 69 64 29 0a 09 20 20 20 t-time pid)..
3120: 20 20 20 20 73 65 72 76 72 29 29 0a 20 20 20 20 servr)).
3130: 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 (tasks:kill-serv
3140: 65 72 20 68 6f 73 74 6e 61 6d 65 20 70 69 64 29 er hostname pid)
3150: 29 29 0a 0a 3b 3b 20 63 61 6c 6c 65 64 20 69 6e ))..;; called in
3160: 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 2c 20 68 megatest.scm, h
3170: 6f 73 74 2d 70 6f 72 74 20 69 73 20 73 74 72 69 ost-port is stri
3180: 6e 67 20 68 6f 73 74 6e 61 6d 65 3a 70 6f 72 74 ng hostname:port
3190: 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 .;;.;; NOTE: Thi
31a0: 73 20 69 73 20 4e 4f 54 20 63 61 6c 6c 65 64 20 s is NOT called
31b0: 64 69 72 65 63 74 6c 79 20 66 72 6f 6d 20 63 6c directly from cl
31c0: 69 65 6e 74 73 20 61 73 20 6e 6f 74 20 61 6c 6c ients as not all
31d0: 20 74 72 61 6e 73 70 6f 72 74 73 20 73 75 70 70 transports supp
31e0: 6f 72 74 20 61 20 63 6c 69 65 6e 74 20 72 75 6e ort a client run
31f0: 6e 69 6e 67 0a 3b 3b 20 20 20 20 20 20 20 69 6e ning.;; in
3200: 20 74 68 65 20 73 61 6d 65 20 70 72 6f 63 65 73 the same proces
3210: 73 20 61 73 20 74 68 65 20 73 65 72 76 65 72 2e s as the server.
3220: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 .;;.(define (ser
3230: 76 65 72 3a 70 69 6e 67 20 68 6f 73 74 2d 70 6f ver:ping host-po
3240: 72 74 2d 69 6e 20 23 21 6b 65 79 20 28 64 6f 2d rt-in #!key (do-
3250: 65 78 69 74 20 23 66 29 29 0a 20 20 28 6c 65 74 exit #f)). (let
3260: 20 28 28 68 6f 73 74 3a 70 6f 72 74 20 28 69 66 ((host:port (if
3270: 20 28 6e 6f 74 20 68 6f 73 74 2d 70 6f 72 74 2d (not host-port-
3280: 69 6e 29 20 3b 3b 20 75 73 65 20 72 65 61 64 2d in) ;; use read-
3290: 64 6f 74 73 65 72 76 65 72 20 74 6f 20 66 69 6e dotserver to fin
32a0: 64 0a 09 09 20 20 20 20 20 20 20 23 66 20 3b 3b d... #f ;;
32b0: 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 (server:check-i
32c0: 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 f-running *toppa
32d0: 74 68 2a 29 0a 09 09 3b 3b 20 28 69 66 20 28 6e th*)...;; (if (n
32e0: 75 6d 62 65 72 3f 20 68 6f 73 74 2d 70 6f 72 74 umber? host-port
32f0: 2d 69 6e 29 20 3b 3b 20 77 65 20 77 65 72 65 20 -in) ;; we were
3300: 68 61 6e 64 65 64 20 61 20 73 65 72 76 65 72 2d handed a server-
3310: 69 64 0a 09 09 3b 3b 20 09 20 20 20 28 6c 65 74 id...;; . (let
3320: 20 28 28 73 72 65 63 20 28 74 61 73 6b 73 3a 67 ((srec (tasks:g
3330: 65 74 2d 73 65 72 76 65 72 2d 62 79 2d 69 64 20 et-server-by-id
3340: 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 (db:delay-if-bus
3350: 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 y (tasks:open-db
3360: 29 29 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 )) host-port-in)
3370: 29 29 0a 09 09 3b 3b 20 09 20 20 20 20 20 3b 3b ))...;; . ;;
3380: 20 28 70 72 69 6e 74 20 22 73 72 65 63 3a 20 22 (print "srec: "
3390: 20 73 72 65 63 20 22 20 68 6f 73 74 2d 70 6f 72 srec " host-por
33a0: 74 2d 69 6e 3a 20 22 20 68 6f 73 74 2d 70 6f 72 t-in: " host-por
33b0: 74 2d 69 6e 29 0a 09 09 3b 3b 20 09 20 20 20 20 t-in)...;; .
33c0: 20 28 69 66 20 73 72 65 63 0a 09 09 3b 3b 20 09 (if srec...;; .
33d0: 09 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d . (conc (vector-
33e0: 72 65 66 20 73 72 65 63 20 33 29 20 22 3a 22 20 ref srec 3) ":"
33f0: 28 76 65 63 74 6f 72 2d 72 65 66 20 73 72 65 63 (vector-ref srec
3400: 20 34 29 29 0a 09 09 3b 3b 20 09 09 20 28 63 6f 4))...;; .. (co
3410: 6e 63 20 22 6e 6f 20 73 75 63 68 20 73 65 72 76 nc "no such serv
3420: 65 72 2d 69 64 20 22 20 68 6f 73 74 2d 70 6f 72 er-id " host-por
3430: 74 2d 69 6e 29 29 29 0a 09 09 20 20 20 20 20 20 t-in)))...
3440: 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 29 29 host-port-in)))
3450: 20 3b 3b 20 29 0a 20 20 20 20 28 6c 65 74 2a 20 ;; ). (let*
3460: 28 28 68 6f 73 74 2d 70 6f 72 74 20 28 69 66 20 ((host-port (if
3470: 68 6f 73 74 3a 70 6f 72 74 0a 09 09 09 20 20 28 host:port.... (
3480: 6c 65 74 20 28 28 73 6c 73 74 20 28 73 74 72 69 let ((slst (stri
3490: 6e 67 2d 73 70 6c 69 74 20 20 20 68 6f 73 74 3a ng-split host:
34a0: 70 6f 72 74 20 22 3a 22 29 29 29 0a 09 09 09 20 port ":")))....
34b0: 20 20 20 28 69 66 20 28 65 71 3f 20 28 6c 65 6e (if (eq? (len
34c0: 67 74 68 20 73 6c 73 74 29 20 32 29 0a 09 09 09 gth slst) 2)....
34d0: 09 28 6c 69 73 74 20 28 63 61 72 20 73 6c 73 74 .(list (car slst
34e0: 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 )(string->number
34f0: 20 28 63 61 64 72 20 73 6c 73 74 29 29 29 0a 09 (cadr slst)))..
3500: 09 09 09 23 66 29 29 0a 09 09 09 20 20 23 66 29 ...#f)).... #f)
3510: 29 29 0a 3b 3b 09 20 20 20 28 74 6f 70 70 61 74 )).;;. (toppat
3520: 68 20 20 20 20 20 20 20 28 6c 61 75 6e 63 68 3a h (launch:
3530: 73 65 74 75 70 29 29 29 0a 20 20 20 20 20 20 3b setup))). ;
3540: 3b 20 28 70 72 69 6e 74 20 22 68 6f 73 74 2d 70 ; (print "host-p
3550: 6f 72 74 3d 22 20 68 6f 73 74 2d 70 6f 72 74 29 ort=" host-port)
3560: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
3570: 68 6f 73 74 2d 70 6f 72 74 29 0a 09 20 20 28 62 host-port).. (b
3580: 65 67 69 6e 0a 09 20 20 20 20 28 69 66 20 68 6f egin.. (if ho
3590: 73 74 2d 70 6f 72 74 2d 69 6e 0a 09 09 28 64 65 st-port-in...(de
35a0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
35b0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
35c0: 22 45 52 52 4f 52 3a 20 62 61 64 20 68 6f 73 74 "ERROR: bad host
35d0: 3a 70 6f 72 74 22 29 29 0a 09 20 20 20 20 28 69 :port")).. (i
35e0: 66 20 64 6f 2d 65 78 69 74 20 28 65 78 69 74 20 f do-exit (exit
35f0: 31 29 29 0a 09 20 20 20 20 23 66 29 0a 09 20 20 1)).. #f)..
3600: 28 6c 65 74 2a 20 28 28 69 66 61 63 65 20 20 20 (let* ((iface
3610: 20 20 20 28 63 61 72 20 68 6f 73 74 2d 70 6f 72 (car host-por
3620: 74 29 29 0a 09 09 20 28 70 6f 72 74 20 20 20 20 t))... (port
3630: 20 20 20 28 63 61 64 72 20 68 6f 73 74 2d 70 6f (cadr host-po
3640: 72 74 29 29 0a 09 09 20 28 73 65 72 76 65 72 2d rt))... (server-
3650: 64 61 74 20 28 68 74 74 70 2d 74 72 61 6e 73 70 dat (http-transp
3660: 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 ort:client-conne
3670: 63 74 20 69 66 61 63 65 20 70 6f 72 74 29 29 0a ct iface port)).
3680: 09 09 20 28 6c 6f 67 69 6e 2d 72 65 73 20 20 28 .. (login-res (
3690: 72 6d 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 rmt:login-no-aut
36a0: 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 73 o-client-setup s
36b0: 65 72 76 65 72 2d 64 61 74 29 29 29 0a 09 20 20 erver-dat)))..
36c0: 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 (if (and (list
36d0: 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 0a 09 09 20 ? login-res)...
36e0: 20 20 20 20 28 63 61 72 20 6c 6f 67 69 6e 2d 72 (car login-r
36f0: 65 73 29 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 es))...(begin...
3700: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 4c 4f 47 ;; (print "LOG
3710: 49 4e 5f 4f 4b 22 29 0a 09 09 20 20 28 69 66 20 IN_OK")... (if
3720: 64 6f 2d 65 78 69 74 20 28 65 78 69 74 20 30 29 do-exit (exit 0)
3730: 29 0a 09 09 20 20 23 74 29 0a 09 09 28 62 65 67 )... #t)...(beg
3740: 69 6e 0a 09 09 20 20 3b 3b 20 28 70 72 69 6e 74 in... ;; (print
3750: 20 22 4c 4f 47 49 4e 5f 46 41 49 4c 45 44 22 29 "LOGIN_FAILED")
3760: 0a 09 09 20 20 28 69 66 20 64 6f 2d 65 78 69 74 ... (if do-exit
3770: 20 28 65 78 69 74 20 31 29 29 0a 09 09 20 20 23 (exit 1))... #
3780: 66 29 29 29 29 29 29 29 0a 0a 3b 3b 20 72 75 6e f)))))))..;; run
3790: 20 70 69 6e 67 20 69 6e 20 73 65 70 61 72 61 74 ping in separat
37a0: 65 20 70 72 6f 63 65 73 73 2c 20 73 61 66 65 73 e process, safes
37b0: 74 20 77 61 79 20 69 6e 20 73 6f 6d 65 20 63 61 t way in some ca
37c0: 73 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ses.;;.(define (
37d0: 73 65 72 76 65 72 3a 70 69 6e 67 2d 73 65 72 76 server:ping-serv
37e0: 65 72 20 69 66 61 63 65 70 6f 72 74 29 0a 20 20 er ifaceport).
37f0: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
3800: 2d 70 69 70 65 20 0a 20 20 20 28 63 6f 6e 63 20 -pipe . (conc
3810: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 (common:get-mega
3820: 74 65 73 74 2d 65 78 65 29 20 22 20 2d 70 69 6e test-exe) " -pin
3830: 67 20 22 20 69 66 61 63 65 70 6f 72 74 29 0a 20 g " ifaceport).
3840: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
3850: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e (let loop ((in
3860: 6c 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 09 l (read-line))..
3870: 09 28 72 65 73 20 22 4e 4f 52 45 50 4c 59 22 29 .(res "NOREPLY")
3880: 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 65 6f ). (if (eo
3890: 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 f-object? inl)..
38a0: 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 (case (string
38b0: 2d 3e 73 79 6d 62 6f 6c 20 72 65 73 29 0a 09 20 ->symbol res)..
38c0: 20 20 20 20 28 28 4e 4f 52 45 50 4c 59 29 20 20 ((NOREPLY)
38d0: 23 66 29 0a 09 20 20 20 20 20 28 28 4c 4f 47 49 #f).. ((LOGI
38e0: 4e 5f 4f 4b 29 20 23 74 29 0a 09 20 20 20 20 20 N_OK) #t)..
38f0: 28 65 6c 73 65 20 20 20 20 20 20 20 23 66 29 29 (else #f))
3900: 0a 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 .. (loop (read
3910: 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 29 29 29 -line) inl))))))
3920: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 ..(define (serve
3930: 72 3a 6c 6f 67 69 6e 20 74 6f 70 70 61 74 68 29 r:login toppath)
3940: 0a 20 20 28 6c 61 6d 62 64 61 20 28 74 6f 70 70 . (lambda (topp
3950: 61 74 68 29 0a 20 20 20 20 28 73 65 74 21 20 2a ath). (set! *
3960: 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 db-last-access*
3970: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
3980: 29 29 20 3b 3b 20 6d 69 67 68 74 20 6e 6f 74 20 )) ;; might not
3990: 62 65 20 6e 65 65 64 65 64 2e 0a 20 20 20 20 28 be needed.. (
39a0: 69 66 20 28 65 71 75 61 6c 3f 20 2a 74 6f 70 70 if (equal? *topp
39b0: 61 74 68 2a 20 74 6f 70 70 61 74 68 29 0a 09 23 ath* toppath)..#
39c0: 74 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e t..#f)))..(defin
39d0: 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 74 69 e (server:get-ti
39e0: 6d 65 6f 75 74 29 0a 20 20 28 6c 65 74 20 28 28 meout). (let ((
39f0: 74 6d 6f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f tmo (configf:loo
3a00: 6b 75 70 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a kup *configdat*
3a10: 20 22 73 65 72 76 65 72 22 20 22 74 69 6d 65 6f "server" "timeo
3a20: 75 74 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 ut"))). (if (
3a30: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 74 6d 6f and (string? tmo
3a40: 29 0a 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d ).. (string-
3a50: 3e 6e 75 6d 62 65 72 20 74 6d 6f 29 29 0a 09 28 >number tmo))..(
3a60: 2a 20 36 30 20 36 30 20 28 73 74 72 69 6e 67 2d * 60 60 (string-
3a70: 3e 6e 75 6d 62 65 72 20 74 6d 6f 29 29 0a 09 3b >number tmo))..;
3a80: 3b 20 28 2a 20 33 20 32 34 20 36 30 20 36 30 29 ; (* 3 24 60 60)
3a90: 20 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f 20 74 ;; default to t
3aa0: 68 72 65 65 20 64 61 79 73 0a 09 28 2a 20 36 30 hree days..(* 60
3ab0: 20 31 29 20 20 20 20 20 20 20 20 20 3b 3b 20 64 1) ;; d
3ac0: 65 66 61 75 6c 74 20 74 6f 20 6f 6e 65 20 6d 69 efault to one mi
3ad0: 6e 75 74 65 0a 09 3b 3b 20 28 2a 20 36 30 20 36 nute..;; (* 60 6
3ae0: 30 20 32 35 29 20 20 20 20 20 20 3b 3b 20 64 65 0 25) ;; de
3af0: 66 61 75 6c 74 20 74 6f 20 32 35 20 68 6f 75 72 fault to 25 hour
3b00: 73 0a 09 29 29 29 0a 0a s..)))..