Artifact
0aa5a0a335abd021031ed4f5d5c447befc7bcda2:
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 7a 6d 71 29 0a t))). ((zmq).
0b90: 20 20 20 20 20 28 6c 65 74 20 28 28 70 75 62 2d (let ((pub-
0ba0: 73 6f 63 6b 65 74 20 28 76 65 63 74 6f 72 2d 72 socket (vector-r
0bb0: 65 66 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 31 ef *runremote* 1
0bc0: 29 29 29 0a 20 20 20 20 20 20 20 28 73 65 6e 64 ))). (send
0bd0: 2d 6d 65 73 73 61 67 65 20 70 75 62 2d 73 6f 63 -message pub-soc
0be0: 6b 65 74 20 72 65 74 75 72 6e 2d 61 64 64 72 20 ket return-addr
0bf0: 73 65 6e 64 2d 6d 6f 72 65 3a 20 23 74 29 0a 20 send-more: #t).
0c00: 20 20 20 20 20 20 28 73 65 6e 64 2d 6d 65 73 73 (send-mess
0c10: 61 67 65 20 70 75 62 2d 73 6f 63 6b 65 74 20 28 age pub-socket (
0c20: 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 28 db:obj->string (
0c30: 76 65 63 74 6f 72 20 73 75 63 63 65 73 73 2f 66 vector success/f
0c40: 61 69 6c 20 71 75 65 72 79 2d 73 69 67 20 72 65 ail query-sig re
0c50: 73 75 6c 74 29 29 29 29 29 0a 20 20 20 20 28 28 sult))))). ((
0c60: 66 73 29 20 20 20 72 65 73 75 6c 74 29 0a 20 20 fs) result).
0c70: 20 20 28 65 6c 73 65 20 0a 20 20 20 20 20 28 64 (else . (d
0c80: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
0c90: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
0ca0: 70 6f 72 74 2a 20 22 75 6e 72 65 63 6f 67 6e 69 port* "unrecogni
0cb0: 73 65 64 20 74 72 61 6e 73 70 6f 72 74 20 74 79 sed transport ty
0cc0: 70 65 3a 20 22 20 2a 74 72 61 6e 73 70 6f 72 74 pe: " *transport
0cd0: 2d 74 79 70 65 2a 29 0a 20 20 20 20 20 72 65 73 -type*). res
0ce0: 75 6c 74 29 29 29 0a 0a 3b 3b 20 47 69 76 65 6e ult)))..;; Given
0cf0: 20 61 20 72 75 6e 20 69 64 20 73 74 61 72 74 20 a run id start
0d00: 61 20 73 65 72 76 65 72 20 70 72 6f 63 65 73 73 a server process
0d10: 20 20 20 20 23 23 23 20 4e 4f 54 45 20 23 23 23 ### NOTE ###
0d20: 20 3e 20 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b > file 2>&1 .;;
0d30: 20 69 66 20 74 68 65 20 72 75 6e 2d 69 64 20 69 if the run-id i
0d40: 73 20 7a 65 72 6f 20 61 6e 64 20 74 68 65 20 74 s zero and the t
0d50: 61 72 67 65 74 2d 68 6f 73 74 20 69 73 20 73 65 arget-host is se
0d60: 74 20 0a 3b 3b 20 74 72 79 20 72 75 6e 6e 69 6e t .;; try runnin
0d70: 67 20 6f 6e 20 74 68 61 74 20 68 6f 73 74 0a 3b g on that host.;
0d80: 3b 20 20 20 69 6e 63 69 64 65 6e 74 61 6c 3a 20 ; incidental:
0d90: 72 6f 74 61 74 65 20 6c 6f 67 73 20 69 6e 20 6c rotate logs in l
0da0: 6f 67 73 2f 20 64 69 72 2e 0a 3b 3b 0a 28 64 65 ogs/ dir..;;.(de
0db0: 66 69 6e 65 20 20 28 73 65 72 76 65 72 3a 72 75 fine (server:ru
0dc0: 6e 20 61 72 65 61 70 61 74 68 29 20 3b 3b 20 61 n areapath) ;; a
0dd0: 72 65 61 70 61 74 68 20 69 73 20 2a 74 6f 70 70 reapath is *topp
0de0: 61 74 68 2a 20 66 6f 72 20 61 20 67 69 76 65 6e ath* for a given
0df0: 20 74 65 73 74 73 75 69 74 65 20 61 72 65 61 0a testsuite area.
0e00: 20 20 28 6c 65 74 2a 20 28 28 63 75 72 72 2d 68 (let* ((curr-h
0e10: 6f 73 74 20 20 20 28 67 65 74 2d 68 6f 73 74 2d ost (get-host-
0e20: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 name)).
0e30: 3b 3b 20 28 61 74 74 65 6d 70 74 2d 69 6e 2d 70 ;; (attempt-in-p
0e40: 72 6f 67 72 65 73 73 20 28 73 65 72 76 65 72 3a rogress (server:
0e50: 73 74 61 72 74 2d 61 74 74 65 6d 70 74 65 64 3f start-attempted?
0e60: 20 61 72 65 61 70 61 74 68 29 29 0a 20 20 20 20 areapath)).
0e70: 20 20 20 20 20 3b 3b 20 28 64 6f 74 2d 73 65 72 ;; (dot-ser
0e80: 76 65 72 2d 75 72 6c 20 28 73 65 72 76 65 72 3a ver-url (server:
0e90: 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 check-if-running
0ea0: 20 61 72 65 61 70 61 74 68 29 29 0a 09 20 28 63 areapath)).. (c
0eb0: 75 72 72 2d 69 70 20 20 20 20 20 28 73 65 72 76 urr-ip (serv
0ec0: 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 er:get-best-gues
0ed0: 73 2d 61 64 64 72 65 73 73 20 63 75 72 72 2d 68 s-address curr-h
0ee0: 6f 73 74 29 29 0a 09 20 28 63 75 72 72 2d 70 69 ost)).. (curr-pi
0ef0: 64 20 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 d (current-pr
0f00: 6f 63 65 73 73 2d 69 64 29 29 0a 09 20 28 68 6f ocess-id)).. (ho
0f10: 6d 65 68 6f 73 74 20 20 20 20 28 63 6f 6d 6d 6f mehost (commo
0f20: 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 n:get-homehost))
0f30: 20 3b 3b 20 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b ;; configf:look
0f40: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
0f50: 73 65 72 76 65 72 22 20 22 68 6f 6d 65 68 6f 73 server" "homehos
0f60: 74 22 20 29 29 0a 09 20 28 74 61 72 67 65 74 2d t" )).. (target-
0f70: 68 6f 73 74 20 28 63 61 72 20 68 6f 6d 65 68 6f host (car homeho
0f80: 73 74 29 29 0a 09 20 28 74 65 73 74 73 75 69 74 st)).. (testsuit
0f90: 65 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d e (common:get-
0fa0: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 testsuite-name))
0fb0: 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 20 20 20 .. (logfile
0fc0: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 (conc areapath "
0fd0: 2f 6c 6f 67 73 2f 73 65 72 76 65 72 2e 6c 6f 67 /logs/server.log
0fe0: 22 29 29 20 3b 3b 20 2d 22 20 63 75 72 72 2d 70 ")) ;; -" curr-p
0ff0: 69 64 20 22 2d 22 20 74 61 72 67 65 74 2d 68 6f id "-" target-ho
1000: 73 74 20 22 2e 6c 6f 67 22 29 29 0a 09 20 28 63 st ".log")).. (c
1010: 6d 64 6c 6e 20 28 63 6f 6e 63 20 28 63 6f 6d 6d mdln (conc (comm
1020: 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 2d on:get-megatest-
1030: 65 78 65 29 0a 09 09 20 20 20 20 20 20 22 20 2d exe)... " -
1040: 73 65 72 76 65 72 20 22 20 28 6f 72 20 74 61 72 server " (or tar
1050: 67 65 74 2d 68 6f 73 74 20 22 2d 22 29 20 28 69 get-host "-") (i
1060: 66 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 f (equal? (confi
1070: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
1080: 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 gdat* "server" "
1090: 64 61 65 6d 6f 6e 69 7a 65 22 29 20 22 79 65 73 daemonize") "yes
10a0: 22 29 0a 09 09 09 09 09 09 09 20 20 20 22 20 2d ")........ " -
10b0: 64 61 65 6d 6f 6e 69 7a 65 20 22 0a 09 09 09 09 daemonize ".....
10c0: 09 09 09 20 20 20 22 22 29 0a 09 09 20 20 20 20 ... "")...
10d0: 20 20 3b 3b 20 22 20 2d 6c 6f 67 20 22 20 6c 6f ;; " -log " lo
10e0: 67 66 69 6c 65 0a 09 09 20 20 20 20 20 20 22 20 gfile... "
10f0: 2d 6d 20 74 65 73 74 73 75 69 74 65 3a 22 20 74 -m testsuite:" t
1100: 65 73 74 73 75 69 74 65 29 29 20 3b 3b 20 28 63 estsuite)) ;; (c
1110: 6f 6e 63 20 22 20 3e 3e 20 22 20 6c 6f 67 66 69 onc " >> " logfi
1120: 6c 65 20 22 20 32 3e 26 31 20 26 22 29 29 29 29 le " 2>&1 &"))))
1130: 29 0a 09 20 28 6c 6f 67 2d 72 6f 74 61 74 65 20 ).. (log-rotate
1140: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 63 6f (make-thread co
1150: 6d 6d 6f 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 mmon:rotate-logs
1160: 20 20 22 73 65 72 76 65 72 20 72 75 6e 2c 20 72 "server run, r
1170: 6f 74 61 74 65 20 6c 6f 67 73 20 74 68 72 65 61 otate logs threa
1180: 64 22 29 29 29 0a 20 20 20 20 3b 3b 20 77 65 20 d"))). ;; we
1190: 77 61 6e 74 20 74 68 65 20 72 65 6d 6f 74 65 20 want the remote
11a0: 73 65 72 76 65 72 20 74 6f 20 73 74 61 72 74 20 server to start
11b0: 69 6e 20 2a 74 6f 70 70 61 74 68 2a 20 73 6f 20 in *toppath* so
11c0: 70 75 73 68 20 74 68 65 72 65 0a 20 20 20 20 28 push there. (
11d0: 70 75 73 68 2d 64 69 72 65 63 74 6f 72 79 20 61 push-directory a
11e0: 72 65 61 70 61 74 68 29 0a 20 20 20 20 28 64 65 reapath). (de
11f0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
1200: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1210: 49 4e 46 4f 3a 20 54 72 79 69 6e 67 20 74 6f 20 INFO: Trying to
1220: 73 74 61 72 74 20 73 65 72 76 65 72 20 28 22 20 start server ("
1230: 63 6d 64 6c 6e 20 22 29 20 2e 2e 2e 22 29 0a 20 cmdln ") ...").
1240: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
1250: 21 20 6c 6f 67 2d 72 6f 74 61 74 65 29 0a 20 20 ! log-rotate).
1260: 20 20 0a 20 20 20 20 3b 3b 20 68 6f 73 74 2e 64 . ;; host.d
1270: 6f 6d 61 69 6e 2e 74 6c 64 20 6d 61 74 63 68 20 omain.tld match
1280: 68 6f 73 74 3f 0a 20 20 20 20 28 69 66 20 28 61 host?. (if (a
1290: 6e 64 20 74 61 72 67 65 74 2d 68 6f 73 74 20 0a nd target-host .
12a0: 09 20 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 61 74 . ;; look at
12b0: 20 74 61 72 67 65 74 20 68 6f 73 74 2c 20 69 73 target host, is
12c0: 20 69 74 20 68 6f 73 74 2e 64 6f 6d 61 69 6e 2e it host.domain.
12d0: 74 6c 64 20 6f 72 20 69 70 20 61 64 64 72 65 73 tld or ip addres
12e0: 73 20 61 6e 64 20 64 6f 65 73 20 69 74 20 0a 09 s and does it ..
12f0: 20 20 20 20 20 3b 3b 20 6d 61 74 63 68 20 63 75 ;; match cu
1300: 72 72 65 6e 74 20 69 70 20 6f 72 20 68 6f 73 74 rrent ip or host
1310: 6e 61 6d 65 0a 09 20 20 20 20 20 28 6e 6f 74 20 name.. (not
1320: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 63 (string-match (c
1330: 6f 6e 63 20 22 28 22 63 75 72 72 2d 68 6f 73 74 onc "("curr-host
1340: 20 22 7c 22 20 63 75 72 72 2d 68 6f 73 74 22 5c "|" curr-host"\
1350: 5c 2e 2e 2a 29 22 29 20 74 61 72 67 65 74 2d 68 \..*)") target-h
1360: 6f 73 74 29 29 0a 09 20 20 20 20 20 28 6e 6f 74 ost)).. (not
1370: 20 28 65 71 75 61 6c 3f 20 63 75 72 72 2d 69 70 (equal? curr-ip
1380: 20 74 61 72 67 65 74 2d 68 6f 73 74 29 29 29 0a target-host))).
1390: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
13a0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
13b0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
13c0: 2a 20 22 53 74 61 72 74 69 6e 67 20 73 65 72 76 * "Starting serv
13d0: 65 72 20 6f 6e 20 22 20 74 61 72 67 65 74 2d 68 er on " target-h
13e0: 6f 73 74 20 22 2c 20 6c 6f 67 66 69 6c 65 20 69 ost ", logfile i
13f0: 73 20 22 20 6c 6f 67 66 69 6c 65 29 0a 09 20 20 s " logfile)..
1400: 28 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 (setenv "TARGETH
1410: 4f 53 54 22 20 74 61 72 67 65 74 2d 68 6f 73 74 OST" target-host
1420: 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 28 ))). . (
1430: 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f setenv "TARGETHO
1440: 53 54 5f 4c 4f 47 46 22 20 22 73 65 72 76 65 72 ST_LOGF" "server
1450: 2e 6c 6f 67 22 29 20 3b 3b 20 6c 6f 67 66 69 6c .log") ;; logfil
1460: 65 29 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 e). (common:w
1470: 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a ait-for-normaliz
1480: 65 64 2d 6c 6f 61 64 20 34 20 22 20 64 65 6c 61 ed-load 4 " dela
1490: 79 69 6e 67 20 73 65 72 76 65 72 20 73 74 61 72 ying server star
14a0: 74 20 64 75 65 20 74 6f 20 6c 6f 61 64 22 20 72 t due to load" r
14b0: 65 6d 6f 74 65 2d 68 6f 73 74 3a 20 28 67 65 74 emote-host: (get
14c0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
14d0: 69 61 62 6c 65 20 22 54 41 52 47 45 54 48 4f 53 iable "TARGETHOS
14e0: 54 22 29 29 20 3b 3b 20 64 6f 20 6e 6f 74 20 74 T")) ;; do not t
14f0: 72 79 20 73 74 61 72 74 69 6e 67 20 73 65 72 76 ry starting serv
1500: 65 72 73 20 6f 6e 20 61 6e 20 61 6c 72 65 61 64 ers on an alread
1510: 79 20 6f 76 65 72 6c 6f 61 64 65 64 20 6d 61 63 y overloaded mac
1520: 68 69 6e 65 2c 20 6a 75 73 74 20 77 61 69 74 20 hine, just wait
1530: 66 6f 72 65 76 65 72 0a 20 20 20 20 28 73 79 73 forever. (sys
1540: 74 65 6d 20 28 63 6f 6e 63 20 22 6e 62 66 61 6b tem (conc "nbfak
1550: 65 20 22 20 63 6d 64 6c 6e 29 29 0a 20 20 20 20 e " cmdln)).
1560: 28 75 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 (unsetenv "TARGE
1570: 54 48 4f 53 54 5f 4c 4f 47 46 22 29 0a 20 20 20 THOST_LOGF").
1580: 20 28 69 66 20 28 67 65 74 2d 65 6e 76 69 72 6f (if (get-enviro
1590: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
15a0: 54 41 52 47 45 54 48 4f 53 54 22 29 28 75 6e 73 TARGETHOST")(uns
15b0: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
15c0: 54 22 29 29 0a 20 20 20 20 28 74 68 72 65 61 64 T")). (thread
15d0: 2d 6a 6f 69 6e 21 20 6c 6f 67 2d 72 6f 74 61 74 -join! log-rotat
15e0: 65 29 0a 20 20 20 20 28 70 6f 70 2d 64 69 72 65 e). (pop-dire
15f0: 63 74 6f 72 79 29 29 29 0a 0a 3b 3b 20 67 69 76 ctory)))..;; giv
1600: 65 6e 20 61 20 70 61 74 68 20 74 6f 20 61 20 73 en a path to a s
1610: 65 72 76 65 72 20 6c 6f 67 20 72 65 74 75 72 6e erver log return
1620: 3a 20 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 : host port star
1630: 74 73 65 63 6f 6e 64 73 0a 3b 3b 0a 28 64 65 66 tseconds.;;.(def
1640: 69 6e 65 20 28 73 65 72 76 65 72 3a 6c 6f 67 66 ine (server:logf
1650: 2d 67 65 74 2d 73 74 61 72 74 2d 69 6e 66 6f 20 -get-start-info
1660: 6c 6f 67 66 29 0a 20 20 28 6c 65 74 20 28 28 72 logf). (let ((r
1670: 78 20 28 72 65 67 65 78 70 20 22 5e 53 45 52 56 x (regexp "^SERV
1680: 45 52 20 53 54 41 52 54 45 44 3a 20 28 5c 5c 53 ER STARTED: (\\S
1690: 2b 29 3a 28 5c 5c 64 2b 29 20 41 54 20 28 5b 5c +):(\\d+) AT ([\
16a0: 5c 64 5c 5c 2e 5d 2b 29 22 29 29 29 20 3b 3b 20 \d\\.]+)"))) ;;
16b0: 53 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 SERVER STARTED:
16c0: 68 6f 73 74 3a 70 6f 72 74 20 41 54 20 74 69 6d host:port AT tim
16d0: 65 73 65 63 73 0a 20 20 20 20 28 77 69 74 68 2d esecs. (with-
16e0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 0a input-from-file.
16f0: 09 6c 6f 67 66 0a 20 20 20 20 20 20 28 6c 61 6d .logf. (lam
1700: 62 64 61 20 28 29 0a 09 28 6c 65 74 20 6c 6f 6f bda ()..(let loo
1710: 70 20 28 28 69 6e 6c 20 20 28 72 65 61 64 2d 6c p ((inl (read-l
1720: 69 6e 65 29 29 0a 09 09 20 20 20 28 6c 6e 75 6d ine))... (lnum
1730: 20 30 29 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 0)).. (if (not
1740: 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e (eof-object? in
1750: 6c 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 l)).. (let
1760: 28 28 6d 6c 73 74 20 28 73 74 72 69 6e 67 2d 6d ((mlst (string-m
1770: 61 74 63 68 20 72 78 20 69 6e 6c 29 29 29 0a 09 atch rx inl)))..
1780: 09 28 69 66 20 28 6e 6f 74 20 6d 6c 73 74 29 0a .(if (not mlst).
1790: 09 09 20 20 20 20 28 69 66 20 28 3c 20 6c 6e 75 .. (if (< lnu
17a0: 6d 20 35 30 30 29 20 3b 3b 20 67 69 76 65 20 75 m 500) ;; give u
17b0: 70 20 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 35 p if more than 5
17c0: 30 30 20 6c 69 6e 65 73 20 6f 66 20 73 65 72 76 00 lines of serv
17d0: 65 72 20 6c 6f 67 20 72 65 61 64 0a 09 09 09 28 er log read....(
17e0: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
17f0: 28 2b 20 6c 6e 75 6d 20 31 29 29 0a 09 09 09 28 (+ lnum 1))....(
1800: 6c 69 73 74 20 23 66 20 23 66 20 23 66 29 29 0a list #f #f #f)).
1810: 09 09 20 20 20 20 28 6c 65 74 20 28 28 64 61 74 .. (let ((dat
1820: 20 20 28 63 64 72 20 6d 6c 73 74 29 29 29 0a 09 (cdr mlst)))..
1830: 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 61 . (list (ca
1840: 72 20 64 61 74 29 20 3b 3b 20 68 6f 73 74 0a 09 r dat) ;; host..
1850: 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e .. (string->n
1860: 75 6d 62 65 72 20 28 63 61 64 72 20 64 61 74 29 umber (cadr dat)
1870: 29 20 3b 3b 20 70 6f 72 74 0a 09 09 09 20 20 20 ) ;; port....
1880: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
1890: 20 28 63 61 64 64 72 20 64 61 74 29 29 29 29 29 (caddr dat)))))
18a0: 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 23 ).. (list #
18b0: 66 20 23 66 20 23 66 29 29 29 29 29 29 29 0a 0a f #f #f)))))))..
18c0: 3b 3b 20 67 65 74 20 61 20 6c 69 73 74 20 6f 66 ;; get a list of
18d0: 20 73 65 72 76 65 72 73 20 77 69 74 68 20 61 6c servers with al
18e0: 6c 20 72 65 6c 65 76 61 6e 74 20 64 61 74 61 0a l relevant data.
18f0: 3b 3b 20 28 20 6d 6f 64 2d 74 69 6d 65 20 68 6f ;; ( mod-time ho
1900: 73 74 20 70 6f 72 74 20 73 74 61 72 74 2d 74 69 st port start-ti
1910: 6d 65 20 70 69 64 20 29 0a 3b 3b 0a 28 64 65 66 me pid ).;;.(def
1920: 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d ine (server:get-
1930: 6c 69 73 74 20 61 72 65 61 70 61 74 68 29 0a 20 list areapath).
1940: 20 28 6c 65 74 20 28 28 66 6e 61 6d 65 2d 72 78 (let ((fname-rx
1950: 20 28 72 65 67 65 78 70 20 22 5e 28 7c 2e 2a 2f (regexp "^(|.*/
1960: 29 73 65 72 76 65 72 2d 28 5c 5c 64 2b 29 2d 28 )server-(\\d+)-(
1970: 5c 5c 53 2b 29 2e 6c 6f 67 24 22 29 29 29 0a 20 \\S+).log$"))).
1980: 20 20 20 3b 3b 20 69 66 20 74 68 65 20 64 69 72 ;; if the dir
1990: 65 63 74 6f 72 79 20 65 78 69 73 74 73 20 63 6f ectory exists co
19a0: 6e 74 69 6e 75 65 20 74 6f 20 67 65 74 20 74 68 ntinue to get th
19b0: 65 20 6c 69 73 74 0a 20 20 20 20 3b 3b 20 6f 74 e list. ;; ot
19c0: 68 65 72 77 69 73 65 20 61 74 74 65 6d 70 74 20 herwise attempt
19d0: 74 6f 20 63 72 65 61 74 65 20 74 68 65 20 6c 6f to create the lo
19e0: 67 73 20 64 69 72 20 61 6e 64 20 74 68 65 6e 0a gs dir and then.
19f0: 20 20 20 20 3b 3b 20 63 6f 6e 74 69 6e 75 65 0a ;; continue.
1a00: 20 20 20 20 28 69 66 20 28 69 66 20 28 64 69 72 (if (if (dir
1a10: 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 28 ectory-exists? (
1a20: 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f conc areapath "/
1a30: 6c 6f 67 73 22 29 29 0a 09 20 20 20 20 23 74 0a logs")).. #t.
1a40: 09 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 77 . (if (file-w
1a50: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 61 72 65 rite-access? are
1a60: 61 70 61 74 68 29 0a 09 09 28 62 65 67 69 6e 0a apath)...(begin.
1a70: 09 09 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 .. (condition-c
1a80: 61 73 65 0a 09 09 20 20 20 20 20 20 28 63 72 65 ase... (cre
1a90: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 28 63 ate-directory (c
1aa0: 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f 6c onc areapath "/l
1ab0: 6f 67 73 22 29 20 23 74 29 0a 09 09 20 20 20 20 ogs") #t)...
1ac0: 28 65 78 6e 20 28 69 2f 6f 20 66 69 6c 65 29 28 (exn (i/o file)(
1ad0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
1ae0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1af0: 20 22 45 52 52 4f 52 3a 20 43 61 6e 6e 6f 74 20 "ERROR: Cannot
1b00: 63 72 65 61 74 65 20 64 69 72 65 63 74 6f 72 79 create directory
1b10: 20 61 74 20 22 20 28 63 6f 6e 63 20 61 72 65 61 at " (conc area
1b20: 70 61 74 68 20 22 2f 6c 6f 67 73 22 29 29 29 0a path "/logs"))).
1b30: 09 09 20 20 20 20 28 65 78 6e 20 28 29 28 64 65 .. (exn ()(de
1b40: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
1b50: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1b60: 45 52 52 4f 52 3a 20 55 6e 6b 6e 6f 77 6e 20 65 ERROR: Unknown e
1b70: 72 72 6f 72 20 61 74 74 65 6d 74 70 69 6e 67 20 rror attemtping
1b80: 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 6c 69 to get server li
1b90: 73 74 2e 22 29 29 29 0a 09 09 20 20 28 64 69 72 st.")))... (dir
1ba0: 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 28 ectory-exists? (
1bb0: 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f conc areapath "/
1bc0: 6c 6f 67 73 22 29 29 29 0a 09 09 23 66 29 29 0a logs")))...#f)).
1bd0: 09 28 6c 65 74 20 28 28 73 65 72 76 65 72 2d 6c .(let ((server-l
1be0: 6f 67 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 ogs (glob (conc
1bf0: 61 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 2f areapath "/logs/
1c00: 73 65 72 76 65 72 2d 2a 2e 6c 6f 67 22 29 29 29 server-*.log")))
1c10: 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ).. (if (null?
1c20: 73 65 72 76 65 72 2d 6c 6f 67 73 29 0a 09 20 20 server-logs)..
1c30: 20 20 20 20 27 28 29 0a 09 20 20 20 20 20 20 28 '().. (
1c40: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 let loop ((hed
1c50: 28 63 61 72 20 73 65 72 76 65 72 2d 6c 6f 67 73 (car server-logs
1c60: 29 29 0a 09 09 09 20 28 74 61 6c 20 20 28 63 64 )).... (tal (cd
1c70: 72 20 73 65 72 76 65 72 2d 6c 6f 67 73 29 29 0a r server-logs)).
1c80: 09 09 09 20 28 72 65 73 20 27 28 29 29 29 0a 09 ... (res '()))..
1c90: 09 28 6c 65 74 2a 20 28 28 6d 6f 64 2d 74 69 6d .(let* ((mod-tim
1ca0: 65 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 e (file-modifica
1cb0: 74 69 6f 6e 2d 74 69 6d 65 20 68 65 64 29 29 0a tion-time hed)).
1cc0: 09 09 20 20 20 20 20 20 20 28 73 65 72 76 2d 64 .. (serv-d
1cd0: 61 74 20 28 73 65 72 76 65 72 3a 6c 6f 67 66 2d at (server:logf-
1ce0: 67 65 74 2d 73 74 61 72 74 2d 69 6e 66 6f 20 68 get-start-info h
1cf0: 65 64 29 29 0a 09 09 20 20 20 20 20 20 20 28 73 ed))... (s
1d00: 65 72 76 2d 72 65 63 20 28 63 6f 6e 73 20 6d 6f erv-rec (cons mo
1d10: 64 2d 74 69 6d 65 20 73 65 72 76 2d 64 61 74 29 d-time serv-dat)
1d20: 29 0a 09 09 20 20 20 20 20 20 20 28 66 6d 61 74 )... (fmat
1d30: 63 68 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 ch (string-mat
1d40: 63 68 20 66 6e 61 6d 65 2d 72 78 20 68 65 64 29 ch fname-rx hed)
1d50: 29 0a 09 09 20 20 20 20 20 20 20 28 70 69 64 20 )... (pid
1d60: 20 20 20 20 20 28 69 66 20 66 6d 61 74 63 68 20 (if fmatch
1d70: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
1d80: 28 6c 69 73 74 2d 72 65 66 20 66 6d 61 74 63 68 (list-ref fmatch
1d90: 20 32 29 29 20 23 66 29 29 0a 09 09 20 20 20 20 2)) #f))...
1da0: 20 20 20 28 6e 65 77 2d 72 65 73 20 20 28 63 6f (new-res (co
1db0: 6e 73 20 28 61 70 70 65 6e 64 20 73 65 72 76 2d ns (append serv-
1dc0: 72 65 63 20 28 6c 69 73 74 20 70 69 64 29 29 20 rec (list pid))
1dd0: 72 65 73 29 29 29 0a 09 09 20 20 28 69 66 20 28 res)))... (if (
1de0: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 null? tal)...
1df0: 20 20 20 6e 65 77 2d 72 65 73 0a 09 09 20 20 20 new-res...
1e00: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
1e10: 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 2d l)(cdr tal) new-
1e20: 72 65 73 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b res)))))))))..;;
1e30: 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 6f 66 given a list of
1e40: 20 73 65 72 76 65 72 73 20 67 65 74 20 61 20 6c servers get a l
1e50: 69 73 74 20 6f 66 20 76 61 6c 69 64 20 73 65 72 ist of valid ser
1e60: 76 65 72 73 2c 20 69 2e 65 2e 20 61 74 20 6c 65 vers, i.e. at le
1e70: 61 73 74 0a 3b 3b 20 31 30 20 73 65 63 6f 6e 64 ast.;; 10 second
1e80: 73 20 6f 6c 64 2c 20 68 61 73 20 73 74 61 72 74 s old, has start
1e90: 65 64 20 61 6e 64 20 69 73 20 6c 65 73 73 20 74 ed and is less t
1ea0: 68 61 6e 20 31 20 68 6f 75 72 20 6f 6c 64 20 61 han 1 hour old a
1eb0: 6e 64 20 69 73 0a 3b 3b 20 61 63 74 69 76 65 20 nd is.;; active
1ec0: 28 69 2e 65 2e 20 6d 6f 64 2d 74 69 6d 65 20 3c (i.e. mod-time <
1ed0: 20 31 30 20 73 65 63 6f 6e 64 73 0a 3b 3b 0a 3b 10 seconds.;;.;
1ee0: 3b 20 6d 6f 64 2d 74 69 6d 65 20 68 6f 73 74 20 ; mod-time host
1ef0: 70 6f 72 74 20 73 74 61 72 74 2d 74 69 6d 65 20 port start-time
1f00: 70 69 64 0a 3b 3b 0a 3b 3b 20 73 6f 72 74 20 62 pid.;;.;; sort b
1f10: 79 20 73 74 61 72 74 2d 74 69 6d 65 20 64 65 73 y start-time des
1f20: 63 65 6e 64 69 6e 67 2e 20 49 2e 65 2e 20 67 65 cending. I.e. ge
1f30: 74 20 74 68 65 20 6f 6c 64 65 73 74 20 66 69 72 t the oldest fir
1f40: 73 74 2e 20 59 6f 75 6e 67 20 73 65 72 76 65 72 st. Young server
1f50: 73 20 77 69 6c 6c 20 74 68 75 73 20 64 72 6f 70 s will thus drop
1f60: 20 6f 66 66 0a 3b 3b 20 61 6e 64 20 73 65 72 76 off.;; and serv
1f70: 65 72 73 20 73 68 6f 75 6c 64 20 73 74 69 63 6b ers should stick
1f80: 20 61 72 6f 75 6e 64 20 66 6f 72 20 61 62 6f 75 around for abou
1f90: 74 20 74 77 6f 20 68 6f 75 72 73 20 6f 72 20 73 t two hours or s
1fa0: 6f 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 o..;;.(define (s
1fb0: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 20 73 erver:get-best s
1fc0: 72 76 6c 73 74 29 0a 20 20 28 6c 65 74 20 28 28 rvlst). (let ((
1fd0: 6e 6f 77 20 28 63 75 72 72 65 6e 74 2d 73 65 63 now (current-sec
1fe0: 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 73 6f 72 onds))). (sor
1ff0: 74 0a 20 20 20 20 20 28 66 69 6c 74 65 72 20 28 t. (filter (
2000: 6c 61 6d 62 64 61 20 28 72 65 63 29 0a 09 20 20 lambda (rec)..
2010: 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 61 72 (let ((star
2020: 74 2d 74 69 6d 65 20 28 6c 69 73 74 2d 72 65 66 t-time (list-ref
2030: 20 72 65 63 20 33 29 29 0a 09 09 20 20 20 20 20 rec 3))...
2040: 28 6d 6f 64 2d 74 69 6d 65 20 20 20 28 6c 69 73 (mod-time (lis
2050: 74 2d 72 65 66 20 72 65 63 20 30 29 29 29 0a 09 t-ref rec 0)))..
2060: 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 73 74 61 . ;; (print "sta
2070: 72 74 2d 74 69 6d 65 3a 20 22 20 73 74 61 72 74 rt-time: " start
2080: 2d 74 69 6d 65 20 22 20 6d 6f 64 2d 74 69 6d 65 -time " mod-time
2090: 3a 20 22 20 6d 6f 64 2d 74 69 6d 65 29 0a 09 09 : " mod-time)...
20a0: 20 28 61 6e 64 20 73 74 61 72 74 2d 74 69 6d 65 (and start-time
20b0: 20 6d 6f 64 2d 74 69 6d 65 0a 09 09 20 20 20 20 mod-time...
20c0: 20 20 28 3e 20 28 2d 20 6e 6f 77 20 73 74 61 72 (> (- now star
20d0: 74 2d 74 69 6d 65 29 20 31 29 20 20 20 20 3b 3b t-time) 1) ;;
20e0: 20 62 65 65 6e 20 72 75 6e 6e 69 6e 67 20 61 74 been running at
20f0: 20 6c 65 61 73 74 20 31 20 73 65 63 6f 6e 64 73 least 1 seconds
2100: 0a 09 09 20 20 20 20 20 20 28 3c 20 28 2d 20 6e ... (< (- n
2110: 6f 77 20 6d 6f 64 2d 74 69 6d 65 29 20 20 20 31 ow mod-time) 1
2120: 30 29 20 20 20 3b 3b 20 73 74 69 6c 6c 20 61 6c 0) ;; still al
2130: 69 76 65 20 2d 20 66 69 6c 65 20 74 6f 75 63 68 ive - file touch
2140: 65 64 20 69 6e 20 6c 61 73 74 20 31 30 20 73 65 ed in last 10 se
2150: 63 6f 6e 64 73 0a 09 09 20 20 20 20 20 20 28 3c conds... (<
2160: 20 28 2d 20 6e 6f 77 20 73 74 61 72 74 2d 74 69 (- now start-ti
2170: 6d 65 29 20 33 36 30 30 29 20 3b 3b 20 75 6e 64 me) 3600) ;; und
2180: 65 72 20 6f 6e 65 20 68 6f 75 72 20 72 75 6e 6e er one hour runn
2190: 69 6e 67 20 74 69 6d 65 0a 09 09 20 20 20 20 20 ing time...
21a0: 20 29 29 29 0a 09 20 20 20 20 20 73 72 76 6c 73 ))).. srvls
21b0: 74 29 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 t). (lambda
21c0: 28 61 20 62 29 0a 20 20 20 20 20 20 20 28 3c 20 (a b). (<
21d0: 28 6c 69 73 74 2d 72 65 66 20 61 20 33 29 0a 09 (list-ref a 3)..
21e0: 20 20 28 6c 69 73 74 2d 72 65 66 20 62 20 33 29 (list-ref b 3)
21f0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
2200: 73 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e 75 server:record->u
2210: 72 6c 20 73 65 72 76 72 29 0a 20 20 28 6d 61 74 rl servr). (mat
2220: 63 68 2d 6c 65 74 20 28 28 28 6d 6f 64 2d 74 69 ch-let (((mod-ti
2230: 6d 65 20 68 6f 73 74 20 70 6f 72 74 20 73 74 61 me host port sta
2240: 72 74 2d 74 69 6d 65 20 70 69 64 29 0a 09 20 20 rt-time pid)..
2250: 20 20 20 20 20 73 65 72 76 72 29 29 0a 20 20 20 servr)).
2260: 20 28 69 66 20 28 61 6e 64 20 68 6f 73 74 20 70 (if (and host p
2270: 6f 72 74 29 0a 09 28 63 6f 6e 63 20 68 6f 73 74 ort)..(conc host
2280: 20 22 3a 22 20 70 6f 72 74 29 0a 09 23 66 29 29 ":" port)..#f))
2290: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 )..(define (serv
22a0: 65 72 3a 67 65 74 2d 63 6c 69 65 6e 74 2d 73 69 er:get-client-si
22b0: 67 6e 61 74 75 72 65 29 20 3b 3b 20 42 42 3e 20 gnature) ;; BB>
22c0: 77 68 79 20 69 73 20 74 68 69 73 20 70 72 6f 63 why is this proc
22d0: 20 6e 61 6d 65 64 20 22 67 65 74 2d 22 3f 20 20 named "get-"?
22e0: 69 74 20 72 65 74 75 72 6e 73 20 6e 6f 74 68 69 it returns nothi
22f0: 6e 67 20 2d 2d 20 73 65 74 21 20 68 61 73 20 6e ng -- set! has n
2300: 6f 74 20 72 65 74 75 72 6e 20 76 61 6c 75 65 2e ot return value.
2310: 0a 20 20 28 69 66 20 2a 6d 79 2d 63 6c 69 65 6e . (if *my-clien
2320: 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 2a 6d 79 t-signature* *my
2330: 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 -client-signatur
2340: 65 2a 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 e*. (let ((
2350: 73 69 67 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 sig (server:mk-s
2360: 69 67 6e 61 74 75 72 65 29 29 29 0a 20 20 20 20 ignature))).
2370: 20 20 20 20 28 73 65 74 21 20 2a 6d 79 2d 63 6c (set! *my-cl
2380: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 ient-signature*
2390: 73 69 67 29 0a 20 20 20 20 20 20 20 20 2a 6d 79 sig). *my
23a0: 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 -client-signatur
23b0: 65 2a 29 29 29 0a 0a 3b 3b 20 6b 69 6e 64 20 73 e*)))..;; kind s
23c0: 74 61 72 74 20 75 70 20 6f 66 20 73 65 72 76 65 tart up of serve
23d0: 72 73 2c 20 77 61 69 74 20 34 30 20 73 65 63 6f rs, wait 40 seco
23e0: 6e 64 73 20 62 65 66 6f 72 65 20 61 6c 6c 6f 77 nds before allow
23f0: 69 6e 67 20 61 6e 6f 74 68 65 72 20 73 65 72 76 ing another serv
2400: 65 72 20 66 6f 72 20 61 20 67 69 76 65 6e 0a 3b er for a given.;
2410: 3b 20 72 75 6e 2d 69 64 20 74 6f 20 62 65 20 6c ; run-id to be l
2420: 61 75 6e 63 68 65 64 0a 28 64 65 66 69 6e 65 20 aunched.(define
2430: 28 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e (server:kind-run
2440: 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 6c 65 areapath). (le
2450: 74 20 28 28 6c 61 73 74 2d 72 75 6e 2d 74 69 6d t ((last-run-tim
2460: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
2470: 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 72 76 65 f/default *serve
2480: 72 2d 6b 69 6e 64 2d 72 75 6e 2a 20 61 72 65 61 r-kind-run* area
2490: 70 61 74 68 20 23 66 29 29 29 0a 20 20 20 20 28 path #f))). (
24a0: 69 66 20 28 6f 72 20 28 6e 6f 74 20 6c 61 73 74 if (or (not last
24b0: 2d 72 75 6e 2d 74 69 6d 65 29 0a 09 20 20 20 20 -run-time)..
24c0: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
24d0: 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d 72 75 6e econds) last-run
24e0: 2d 74 69 6d 65 29 20 33 30 29 29 0a 09 28 62 65 -time) 30))..(be
24f0: 67 69 6e 0a 09 20 20 28 73 65 72 76 65 72 3a 72 gin.. (server:r
2500: 75 6e 20 61 72 65 61 70 61 74 68 29 0a 09 20 20 un areapath)..
2510: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
2520: 20 2a 73 65 72 76 65 72 2d 6b 69 6e 64 2d 72 75 *server-kind-ru
2530: 6e 2a 20 61 72 65 61 70 61 74 68 20 28 63 75 72 n* areapath (cur
2540: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 rent-seconds))))
2550: 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 65 72 76 ))..(define serv
2560: 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e 67 20 73 er:try-running s
2570: 65 72 76 65 72 3a 72 75 6e 29 20 3b 3b 20 74 68 erver:run) ;; th
2580: 65 72 65 20 69 73 20 6e 6f 20 6d 6f 72 65 20 70 ere is no more p
2590: 65 72 2d 72 75 6e 20 73 65 72 76 65 72 73 20 3b er-run servers ;
25a0: 3b 20 52 45 4d 4f 56 45 20 4d 45 2e 20 42 55 47 ; REMOVE ME. BUG
25b0: 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 ...(define (serv
25c0: 65 72 3a 64 6f 74 73 65 72 76 65 72 2d 61 67 65 er:dotserver-age
25d0: 2d 73 65 63 6f 6e 64 73 20 61 72 65 61 70 61 74 -seconds areapat
25e0: 68 29 0a 20 20 28 6c 65 74 20 28 28 73 65 72 76 h). (let ((serv
25f0: 65 72 2d 66 69 6c 65 20 28 63 6f 6e 63 20 61 72 er-file (conc ar
2600: 65 61 70 61 74 68 20 22 2f 2e 73 65 72 76 65 72 eapath "/.server
2610: 22 29 29 29 0a 20 20 20 20 28 62 65 67 69 6e 0a "))). (begin.
2620: 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 (handle-ex
2630: 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 ceptions.
2640: 65 78 6e 0a 20 20 20 20 20 20 20 23 66 0a 20 20 exn. #f.
2650: 20 20 20 20 20 28 2d 20 28 63 75 72 72 65 6e 74 (- (current
2660: 2d 73 65 63 6f 6e 64 73 29 0a 20 20 20 20 20 20 -seconds).
2670: 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 (file-modifi
2680: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 65 72 76 cation-time serv
2690: 65 72 2d 66 69 6c 65 29 29 29 29 29 29 0a 20 20 er-file)))))).
26a0: 20 20 0a 3b 3b 20 6e 6f 20 6c 6f 6e 67 65 72 20 .;; no longer
26b0: 63 61 72 65 20 69 66 20 6d 75 6c 74 69 70 6c 65 care if multiple
26c0: 20 73 65 72 76 65 72 73 20 61 72 65 20 73 74 61 servers are sta
26d0: 72 74 65 64 20 62 79 20 61 63 63 69 64 65 6e 74 rted by accident
26e0: 2e 20 6f 6c 64 65 72 20 73 65 72 76 65 72 73 20 . older servers
26f0: 77 69 6c 6c 20 64 72 6f 70 20 6f 66 66 20 69 6e will drop off in
2700: 20 74 69 6d 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e time..;;.(defin
2710: 65 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d e (server:check-
2720: 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 if-running areap
2730: 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 ath). (let* ((s
2740: 65 72 76 65 72 73 20 20 20 20 20 20 20 28 73 65 ervers (se
2750: 72 76 65 72 3a 67 65 74 2d 62 65 73 74 20 28 73 rver:get-best (s
2760: 65 72 76 65 72 3a 67 65 74 2d 6c 69 73 74 20 61 erver:get-list a
2770: 72 65 61 70 61 74 68 29 29 29 0a 09 20 28 62 65 reapath))).. (be
2780: 73 74 2d 73 65 72 76 65 72 20 20 20 28 69 66 20 st-server (if
2790: 28 6e 75 6c 6c 3f 20 73 65 72 76 65 72 73 29 20 (null? servers)
27a0: 23 66 20 28 63 61 72 20 73 65 72 76 65 72 73 29 #f (car servers)
27b0: 29 29 0a 09 20 28 64 6f 74 73 65 72 76 65 72 2d )).. (dotserver-
27c0: 75 72 6c 20 28 69 66 20 62 65 73 74 2d 73 65 72 url (if best-ser
27d0: 76 65 72 0a 09 09 09 20 20 20 20 28 73 65 72 76 ver.... (serv
27e0: 65 72 3a 72 65 63 6f 72 64 2d 3e 75 72 6c 20 62 er:record->url b
27f0: 65 73 74 2d 73 65 72 76 65 72 29 0a 09 09 09 20 est-server)....
2800: 20 20 20 23 66 29 29 29 20 3b 3b 20 28 73 65 72 #f))) ;; (ser
2810: 76 65 72 3a 72 65 61 64 2d 64 6f 74 73 65 72 76 ver:read-dotserv
2820: 65 72 2d 3e 75 72 6c 20 61 72 65 61 70 61 74 68 er->url areapath
2830: 29 29 29 20 3b 3b 20 74 64 62 64 61 74 20 28 74 ))) ;; tdbdat (t
2840: 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 0a asks:open-db))).
2850: 20 20 20 20 28 69 66 20 64 6f 74 73 65 72 76 65 (if dotserve
2860: 72 2d 75 72 6c 0a 09 28 6c 65 74 2a 20 28 28 72 r-url..(let* ((r
2870: 65 73 20 28 63 61 73 65 20 2a 74 72 61 6e 73 70 es (case *transp
2880: 6f 72 74 2d 74 79 70 65 2a 0a 09 09 20 20 20 20 ort-type*...
2890: 20 20 28 28 68 74 74 70 29 28 73 65 72 76 65 72 ((http)(server
28a0: 3a 70 69 6e 67 2d 73 65 72 76 65 72 20 64 6f 74 :ping-server dot
28b0: 73 65 72 76 65 72 2d 75 72 6c 29 29 0a 09 09 20 server-url))...
28c0: 20 20 20 20 20 3b 3b 20 28 28 6e 6d 73 67 29 28 ;; ((nmsg)(
28d0: 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 70 nmsg-transport:p
28e0: 69 6e 67 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 ing (tasks:hosti
28f0: 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 72 66 61 63 nfo-get-interfac
2900: 65 20 73 65 72 76 65 72 29 0a 09 09 20 20 20 20 e server)...
2910: 20 20 29 29 29 0a 09 20 20 28 69 66 20 72 65 73 ))).. (if res
2920: 0a 09 20 20 20 20 20 20 64 6f 74 73 65 72 76 65 .. dotserve
2930: 72 2d 75 72 6c 0a 09 20 20 20 20 20 20 28 62 65 r-url.. (be
2940: 67 69 6e 0a 09 09 28 73 65 72 76 65 72 3a 6b 69 gin...(server:ki
2950: 6c 6c 20 62 65 73 74 2d 73 65 72 76 65 72 29 0a ll best-server).
2960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2970: 23 66 29 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 #f)))..#f)))..(d
2980: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6b 69 efine (server:ki
2990: 6c 6c 20 73 65 72 76 72 29 0a 20 20 28 6d 61 74 ll servr). (mat
29a0: 63 68 2d 6c 65 74 20 28 28 28 6d 6f 64 2d 74 69 ch-let (((mod-ti
29b0: 6d 65 20 68 6f 73 74 6e 61 6d 65 20 70 6f 72 74 me hostname port
29c0: 20 73 74 61 72 74 2d 74 69 6d 65 20 70 69 64 29 start-time pid)
29d0: 0a 09 20 20 20 20 20 20 20 73 65 72 76 72 29 29 .. servr))
29e0: 0a 20 20 20 20 28 74 61 73 6b 73 3a 6b 69 6c 6c . (tasks:kill
29f0: 2d 73 65 72 76 65 72 20 68 6f 73 74 6e 61 6d 65 -server hostname
2a00: 20 70 69 64 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c pid)))..;; call
2a10: 65 64 20 69 6e 20 6d 65 67 61 74 65 73 74 2e 73 ed in megatest.s
2a20: 63 6d 2c 20 68 6f 73 74 2d 70 6f 72 74 20 69 73 cm, host-port is
2a30: 20 73 74 72 69 6e 67 20 68 6f 73 74 6e 61 6d 65 string hostname
2a40: 3a 70 6f 72 74 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 :port.;;.;; NOTE
2a50: 3a 20 54 68 69 73 20 69 73 20 4e 4f 54 20 63 61 : This is NOT ca
2a60: 6c 6c 65 64 20 64 69 72 65 63 74 6c 79 20 66 72 lled directly fr
2a70: 6f 6d 20 63 6c 69 65 6e 74 73 20 61 73 20 6e 6f om clients as no
2a80: 74 20 61 6c 6c 20 74 72 61 6e 73 70 6f 72 74 73 t all transports
2a90: 20 73 75 70 70 6f 72 74 20 61 20 63 6c 69 65 6e support a clien
2aa0: 74 20 72 75 6e 6e 69 6e 67 0a 3b 3b 20 20 20 20 t running.;;
2ab0: 20 20 20 69 6e 20 74 68 65 20 73 61 6d 65 20 70 in the same p
2ac0: 72 6f 63 65 73 73 20 61 73 20 74 68 65 20 73 65 rocess as the se
2ad0: 72 76 65 72 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 rver..;;.(define
2ae0: 20 28 73 65 72 76 65 72 3a 70 69 6e 67 20 68 6f (server:ping ho
2af0: 73 74 2d 70 6f 72 74 2d 69 6e 20 23 21 6b 65 79 st-port-in #!key
2b00: 20 28 64 6f 2d 65 78 69 74 20 23 66 29 29 0a 20 (do-exit #f)).
2b10: 20 28 6c 65 74 20 28 28 68 6f 73 74 3a 70 6f 72 (let ((host:por
2b20: 74 20 28 69 66 20 28 6e 6f 74 20 68 6f 73 74 2d t (if (not host-
2b30: 70 6f 72 74 2d 69 6e 29 20 3b 3b 20 75 73 65 20 port-in) ;; use
2b40: 72 65 61 64 2d 64 6f 74 73 65 72 76 65 72 20 74 read-dotserver t
2b50: 6f 20 66 69 6e 64 0a 09 09 20 20 20 20 20 20 20 o find...
2b60: 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 (server:check-if
2b70: 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 -running *toppat
2b80: 68 2a 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 h*)... (if
2b90: 20 28 6e 75 6d 62 65 72 3f 20 68 6f 73 74 2d 70 (number? host-p
2ba0: 6f 72 74 2d 69 6e 29 20 3b 3b 20 77 65 20 77 65 ort-in) ;; we we
2bb0: 72 65 20 68 61 6e 64 65 64 20 61 20 73 65 72 76 re handed a serv
2bc0: 65 72 2d 69 64 0a 09 09 09 20 20 20 28 6c 65 74 er-id.... (let
2bd0: 20 28 28 73 72 65 63 20 28 74 61 73 6b 73 3a 67 ((srec (tasks:g
2be0: 65 74 2d 73 65 72 76 65 72 2d 62 79 2d 69 64 20 et-server-by-id
2bf0: 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 (db:delay-if-bus
2c00: 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 y (tasks:open-db
2c10: 29 29 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 )) host-port-in)
2c20: 29 29 0a 09 09 09 20 20 20 20 20 3b 3b 20 28 70 )).... ;; (p
2c30: 72 69 6e 74 20 22 73 72 65 63 3a 20 22 20 73 72 rint "srec: " sr
2c40: 65 63 20 22 20 68 6f 73 74 2d 70 6f 72 74 2d 69 ec " host-port-i
2c50: 6e 3a 20 22 20 68 6f 73 74 2d 70 6f 72 74 2d 69 n: " host-port-i
2c60: 6e 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 73 n).... (if s
2c70: 72 65 63 0a 09 09 09 09 20 28 63 6f 6e 63 20 28 rec..... (conc (
2c80: 76 65 63 74 6f 72 2d 72 65 66 20 73 72 65 63 20 vector-ref srec
2c90: 33 29 20 22 3a 22 20 28 76 65 63 74 6f 72 2d 72 3) ":" (vector-r
2ca0: 65 66 20 73 72 65 63 20 34 29 29 0a 09 09 09 09 ef srec 4)).....
2cb0: 20 28 63 6f 6e 63 20 22 6e 6f 20 73 75 63 68 20 (conc "no such
2cc0: 73 65 72 76 65 72 2d 69 64 20 22 20 68 6f 73 74 server-id " host
2cd0: 2d 70 6f 72 74 2d 69 6e 29 29 29 0a 09 09 09 20 -port-in)))....
2ce0: 20 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 29 host-port-in))
2cf0: 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 68 )). (let* ((h
2d00: 6f 73 74 2d 70 6f 72 74 20 28 69 66 20 68 6f 73 ost-port (if hos
2d10: 74 3a 70 6f 72 74 0a 09 09 09 20 20 28 6c 65 74 t:port.... (let
2d20: 20 28 28 73 6c 73 74 20 28 73 74 72 69 6e 67 2d ((slst (string-
2d30: 73 70 6c 69 74 20 20 20 68 6f 73 74 3a 70 6f 72 split host:por
2d40: 74 20 22 3a 22 29 29 29 0a 09 09 09 20 20 20 20 t ":")))....
2d50: 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 (if (eq? (length
2d60: 20 73 6c 73 74 29 20 32 29 0a 09 09 09 09 28 6c slst) 2).....(l
2d70: 69 73 74 20 28 63 61 72 20 73 6c 73 74 29 28 73 ist (car slst)(s
2d80: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 tring->number (c
2d90: 61 64 72 20 73 6c 73 74 29 29 29 0a 09 09 09 09 adr slst))).....
2da0: 23 66 29 29 0a 09 09 09 20 20 23 66 29 29 0a 09 #f)).... #f))..
2db0: 20 20 20 28 74 6f 70 70 61 74 68 20 20 20 20 20 (toppath
2dc0: 20 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 29 (launch:setup)
2dd0: 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 70 72 69 )). ;; (pri
2de0: 6e 74 20 22 68 6f 73 74 2d 70 6f 72 74 3d 22 20 nt "host-port="
2df0: 68 6f 73 74 2d 70 6f 72 74 29 0a 20 20 20 20 20 host-port).
2e00: 20 28 69 66 20 28 6e 6f 74 20 68 6f 73 74 2d 70 (if (not host-p
2e10: 6f 72 74 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 ort).. (begin..
2e20: 20 20 20 20 28 69 66 20 68 6f 73 74 2d 70 6f 72 (if host-por
2e30: 74 2d 69 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 t-in...(debug:pr
2e40: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
2e50: 6f 67 2d 70 6f 72 74 2a 20 20 22 45 52 52 4f 52 og-port* "ERROR
2e60: 3a 20 62 61 64 20 68 6f 73 74 3a 70 6f 72 74 22 : bad host:port"
2e70: 29 29 0a 09 20 20 20 20 28 69 66 20 64 6f 2d 65 )).. (if do-e
2e80: 78 69 74 20 28 65 78 69 74 20 31 29 29 0a 09 20 xit (exit 1))..
2e90: 20 20 20 23 66 29 0a 09 20 20 28 6c 65 74 2a 20 #f).. (let*
2ea0: 28 28 69 66 61 63 65 20 20 20 20 20 20 28 63 61 ((iface (ca
2eb0: 72 20 68 6f 73 74 2d 70 6f 72 74 29 29 0a 09 09 r host-port))...
2ec0: 20 28 70 6f 72 74 20 20 20 20 20 20 20 28 63 61 (port (ca
2ed0: 64 72 20 68 6f 73 74 2d 70 6f 72 74 29 29 0a 09 dr host-port))..
2ee0: 09 20 28 73 65 72 76 65 72 2d 64 61 74 20 28 68 . (server-dat (h
2ef0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
2f00: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 ient-connect ifa
2f10: 63 65 20 70 6f 72 74 29 29 0a 09 09 20 28 6c 6f ce port))... (lo
2f20: 67 69 6e 2d 72 65 73 20 20 28 72 6d 74 3a 6c 6f gin-res (rmt:lo
2f30: 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 gin-no-auto-clie
2f40: 6e 74 2d 73 65 74 75 70 20 73 65 72 76 65 72 2d nt-setup server-
2f50: 64 61 74 29 29 29 0a 09 20 20 20 20 28 69 66 20 dat))).. (if
2f60: 28 61 6e 64 20 28 6c 69 73 74 3f 20 6c 6f 67 69 (and (list? logi
2f70: 6e 2d 72 65 73 29 0a 09 09 20 20 20 20 20 28 63 n-res)... (c
2f80: 61 72 20 6c 6f 67 69 6e 2d 72 65 73 29 29 0a 09 ar login-res))..
2f90: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 70 72 69 .(begin... (pri
2fa0: 6e 74 20 22 4c 4f 47 49 4e 5f 4f 4b 22 29 0a 09 nt "LOGIN_OK")..
2fb0: 09 20 20 28 69 66 20 64 6f 2d 65 78 69 74 20 28 . (if do-exit (
2fc0: 65 78 69 74 20 30 29 29 29 0a 09 09 28 62 65 67 exit 0)))...(beg
2fd0: 69 6e 0a 09 09 20 20 28 70 72 69 6e 74 20 22 4c in... (print "L
2fe0: 4f 47 49 4e 5f 46 41 49 4c 45 44 22 29 0a 09 09 OGIN_FAILED")...
2ff0: 20 20 28 69 66 20 64 6f 2d 65 78 69 74 20 28 65 (if do-exit (e
3000: 78 69 74 20 31 29 29 29 29 29 29 29 29 29 0a 0a xit 1)))))))))..
3010: 3b 3b 20 72 75 6e 20 70 69 6e 67 20 69 6e 20 73 ;; run ping in s
3020: 65 70 61 72 61 74 65 20 70 72 6f 63 65 73 73 2c eparate process,
3030: 20 73 61 66 65 73 74 20 77 61 79 20 69 6e 20 73 safest way in s
3040: 6f 6d 65 20 63 61 73 65 73 0a 3b 3b 0a 28 64 65 ome cases.;;.(de
3050: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 70 69 6e fine (server:pin
3060: 67 2d 73 65 72 76 65 72 20 69 66 61 63 65 70 6f g-server ifacepo
3070: 72 74 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 rt). (with-inpu
3080: 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 t-from-pipe .
3090: 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (conc (common:ge
30a0: 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 29 20 t-megatest-exe)
30b0: 22 20 2d 70 69 6e 67 20 22 20 69 66 61 63 65 70 " -ping " ifacep
30c0: 6f 72 74 29 0a 20 20 20 28 6c 61 6d 62 64 61 20 ort). (lambda
30d0: 28 29 0a 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f (). (let loo
30e0: 70 20 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 p ((inl (read-li
30f0: 6e 65 29 29 0a 09 09 28 72 65 73 20 22 4e 4f 52 ne))...(res "NOR
3100: 45 50 4c 59 22 29 29 0a 20 20 20 20 20 20 20 28 EPLY")). (
3110: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
3120: 69 6e 6c 29 0a 09 20 20 20 28 63 61 73 65 20 28 inl).. (case (
3130: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 72 string->symbol r
3140: 65 73 29 0a 09 20 20 20 20 20 28 28 4e 4f 52 45 es).. ((NORE
3150: 50 4c 59 29 20 20 23 66 29 0a 09 20 20 20 20 20 PLY) #f)..
3160: 28 28 4c 4f 47 49 4e 5f 4f 4b 29 20 23 74 29 0a ((LOGIN_OK) #t).
3170: 09 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 . (else
3180: 20 20 23 66 29 29 0a 09 20 20 20 28 6c 6f 6f 70 #f)).. (loop
3190: 20 28 72 65 61 64 2d 6c 69 6e 65 29 20 69 6e 6c (read-line) inl
31a0: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
31b0: 28 73 65 72 76 65 72 3a 6c 6f 67 69 6e 20 74 6f (server:login to
31c0: 70 70 61 74 68 29 0a 20 20 28 6c 61 6d 62 64 61 ppath). (lambda
31d0: 20 28 74 6f 70 70 61 74 68 29 0a 20 20 20 20 28 (toppath). (
31e0: 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 set! *db-last-ac
31f0: 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 cess* (current-s
3200: 65 63 6f 6e 64 73 29 29 20 3b 3b 20 6d 69 67 68 econds)) ;; migh
3210: 74 20 6e 6f 74 20 62 65 20 6e 65 65 64 65 64 2e t not be needed.
3220: 0a 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f . (if (equal?
3230: 20 2a 74 6f 70 70 61 74 68 2a 20 74 6f 70 70 61 *toppath* toppa
3240: 74 68 29 0a 09 23 74 0a 09 23 66 29 29 29 0a 0a th)..#t..#f)))..
3250: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
3260: 67 65 74 2d 74 69 6d 65 6f 75 74 29 0a 20 20 28 get-timeout). (
3270: 6c 65 74 20 28 28 74 6d 6f 20 28 63 6f 6e 66 69 let ((tmo (confi
3280: 67 66 3a 6c 6f 6f 6b 75 70 20 20 2a 63 6f 6e 66 gf:lookup *conf
3290: 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 igdat* "server"
32a0: 22 74 69 6d 65 6f 75 74 22 29 29 29 0a 20 20 20 "timeout"))).
32b0: 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e (if (and (strin
32c0: 67 3f 20 74 6d 6f 29 0a 09 20 20 20 20 20 28 73 g? tmo).. (s
32d0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 74 6d tring->number tm
32e0: 6f 29 29 0a 09 28 2a 20 36 30 20 36 30 20 28 73 o))..(* 60 60 (s
32f0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 74 6d tring->number tm
3300: 6f 29 29 0a 09 3b 3b 20 28 2a 20 33 20 32 34 20 o))..;; (* 3 24
3310: 36 30 20 36 30 29 20 3b 3b 20 64 65 66 61 75 6c 60 60) ;; defaul
3320: 74 20 74 6f 20 74 68 72 65 65 20 64 61 79 73 0a t to three days.
3330: 09 28 2a 20 36 30 20 31 29 20 20 20 20 20 20 20 .(* 60 1)
3340: 20 20 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f 20 ;; default to
3350: 6f 6e 65 20 6d 69 6e 75 74 65 0a 09 3b 3b 20 28 one minute..;; (
3360: 2a 20 36 30 20 36 30 20 32 35 29 20 20 20 20 20 * 60 60 25)
3370: 20 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f 20 32 ;; default to 2
3380: 35 20 68 6f 75 72 73 0a 09 29 29 29 0a 0a 5 hours..)))..