0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 36 2d 32 30 31 37 2c 20 4d 61 74 74 68 65 77 20 6-2017, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 72 This file is par
0040: 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a 3b t of Megatest..;
0050: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
0060: 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 77 st is free softw
0070: 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 64 are: you can red
0080: 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e 64 istribute it and
0090: 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 20 /or modify.;;
00a0: 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 74 it under the t
00b0: 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 20 erms of the GNU
00c0: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
00d0: 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 73 icense as publis
00e0: 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 68 hed by.;; th
00f0: 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 20 e Free Software
0100: 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 68 Foundation, eith
0110: 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 20 er version 3 of
0120: 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 0a the License, or.
0130: 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 20 ;; (at your
0140: 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 65 option) any late
0150: 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a 3b r version..;; .;
0160: 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 69 ; Megatest i
0170: 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 6e s distributed in
0180: 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 69 the hope that i
0190: 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 6c t will be useful
01a0: 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 54 ,.;; but WIT
01b0: 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e 54 HOUT ANY WARRANT
01c0: 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e 20 Y; without even
01d0: 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 72 the implied warr
01e0: 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 4d anty of.;; M
01f0: 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 6f ERCHANTABILITY o
0200: 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 20 r FITNESS FOR A
0210: 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 4f PARTICULAR PURPO
0220: 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b 20 SE. See the.;;
0230: 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 GNU General
0240: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 66 Public License f
0250: 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 2e or more details.
0260: 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 20 .;; .;; You
0270: 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 65 should have rece
0280: 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 74 ived a copy of t
0290: 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 he GNU General P
02a0: 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b 3b ublic License.;;
02b0: 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 20 along with
02c0: 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e 6f Megatest. If no
02d0: 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f 77 t, see <http://w
02e0: 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 6e ww.gnu.org/licen
02f0: 73 65 73 2f 3e 2e 0a 3b 3b 0a 0a 28 64 65 63 6c ses/>..;;..(decl
0300: 61 72 65 20 28 75 6e 69 74 20 73 65 72 76 65 72 are (unit server
0310: 6d 6f 64 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 mod))..(declare
0320: 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 (uses commonmod)
0330: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0340: 20 63 6f 6e 66 69 67 66 6d 6f 64 29 29 0a 28 64 configfmod)).(d
0350: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 6d eclare (uses mtm
0360: 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 od)).(declare (u
0370: 73 65 73 20 64 65 62 75 67 70 72 69 6e 74 29 29 ses debugprint))
0380: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0390: 6d 74 61 72 67 73 29 29 0a 0a 28 6d 6f 64 75 6c mtargs))..(modul
03a0: 65 20 73 65 72 76 65 72 6d 6f 64 0a 09 28 0a 09 e servermod..(..
03b0: 20 29 0a 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 )..(import sche
03c0: 6d 65 0a 09 63 68 69 63 6b 65 6e 29 0a 09 0a 28 me..chicken)...(
03d0: 75 73 65 20 28 73 72 66 69 20 31 38 29 20 65 78 use (srfi 18) ex
03e0: 74 72 61 73 20 73 31 31 6e 29 0a 28 75 73 65 20 tras s11n).(use
03f0: 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 srfi-1 posix reg
0400: 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 ex regex-case sr
0410: 66 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d fi-69 hostinfo m
0420: 64 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 d5 message-diges
0430: 74 29 0a 28 75 73 65 20 64 69 72 65 63 74 6f 72 t).(use director
0440: 79 2d 75 74 69 6c 73 20 70 6f 73 69 78 2d 65 78 y-utils posix-ex
0450: 74 72 61 73 20 6d 61 74 63 68 61 62 6c 65 20 75 tras matchable u
0460: 74 69 6c 73 29 0a 28 75 73 65 20 73 70 69 66 66 tils).(use spiff
0470: 79 20 75 72 69 2d 63 6f 6d 6d 6f 6e 20 69 6e 74 y uri-common int
0480: 61 72 77 65 62 20 68 74 74 70 2d 63 6c 69 65 6e arweb http-clien
0490: 74 20 73 70 69 66 66 79 2d 72 65 71 75 65 73 74 t spiffy-request
04a0: 2d 76 61 72 73 29 0a 0a 28 69 6d 70 6f 72 74 20 -vars)..(import
04b0: 70 6f 72 74 73 0a 09 64 61 74 61 2d 73 74 72 75 ports..data-stru
04c0: 63 74 75 72 65 73 0a 09 66 69 6c 65 73 0a 09 73 ctures..files..s
04d0: 72 66 69 2d 34 0a 09 74 79 70 65 64 2d 72 65 63 rfi-4..typed-rec
04e0: 6f 72 64 73 0a 09 0a 09 63 6f 6d 6d 6f 6e 6d 6f ords....commonmo
04f0: 64 0a 09 63 6f 6e 66 69 67 66 6d 6f 64 0a 09 64 d..configfmod..d
0500: 65 62 75 67 70 72 69 6e 74 0a 09 28 70 72 65 66 ebugprint..(pref
0510: 69 78 20 6d 74 61 72 67 73 20 61 72 67 73 3a 29 ix mtargs args:)
0520: 0a 09 6d 74 6d 6f 64 0a 09 29 0a 0a 3b 3b 20 28 ..mtmod..)..;; (
0530: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
0540: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 3b 3b records.scm").;;
0550: 20 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 (include "db_re
0560: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 64 65 cords.scm")..(de
0570: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6d 61 6b fine (server:mak
0580: 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 68 6f 73 e-server-url hos
0590: 74 70 6f 72 74 29 0a 20 20 28 69 66 20 28 6e 6f tport). (if (no
05a0: 74 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 20 20 t hostport).
05b0: 20 20 23 66 0a 20 20 20 20 20 20 28 63 6f 6e 63 #f. (conc
05c0: 20 22 68 74 74 70 3a 2f 2f 22 20 28 63 61 72 20 "http://" (car
05d0: 68 6f 73 74 70 6f 72 74 29 20 22 3a 22 20 28 63 hostport) ":" (c
05e0: 61 64 72 20 68 6f 73 74 70 6f 72 74 29 29 29 29 adr hostport))))
05f0: 0a 0a 28 64 65 66 69 6e 65 20 20 2a 73 65 72 76 ..(define *serv
0600: 65 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 2d 62 65 er-loop-heart-be
0610: 61 74 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 at* (current-sec
0620: 6f 6e 64 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d onds))..;;======
0630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0670: 0a 3b 3b 20 50 20 4b 20 54 20 53 20 20 20 53 20 .;; P K T S S
0680: 54 20 55 20 46 20 46 20 0a 3b 3b 3d 3d 3d 3d 3d T U F F .;;=====
0690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06a0: 3d 3d 3d 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 0a 0a 3b 3b 20 3f 3f 3f 0a 0a 3b 3b 3d 3d 3d =..;; ???..;;===
06e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0720: 3d 3d 3d 0a 3b 3b 20 50 20 4b 20 54 20 53 20 20 ===.;; P K T S
0730: 20 53 20 54 20 55 20 46 20 46 20 0a 3b 3b 3d 3d S T U F F .;;==
0740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 3d 3d 0a 0a 3b 3b 20 3f 3f 3f 0a 0a 3b 3b ====..;; ???..;;
0790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07d0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 ======.;; S E R
07e0: 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d V E R.;;========
07f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0830: 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 ;; Call this to
0840: 73 74 61 72 74 20 74 68 65 20 61 63 74 75 61 6c start the actual
0850: 20 73 65 72 76 65 72 0a 3b 3b 0a 0a 3b 3b 3d 3d server.;;..;;==
0860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08a0: 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 56 20 ====.;; S E R V
08b0: 45 20 52 20 20 20 55 20 54 20 49 20 4c 20 49 20 E R U T I L I
08c0: 54 20 49 20 45 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d T I E S .;;=====
08d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0910: 3d 0a 0a 3b 3b 20 47 65 74 20 74 68 65 20 74 72 =..;; Get the tr
0920: 61 6e 73 70 6f 72 74 0a 28 64 65 66 69 6e 65 20 ansport.(define
0930: 28 73 65 72 76 65 72 3a 67 65 74 2d 74 72 61 6e (server:get-tran
0940: 73 70 6f 72 74 29 0a 20 20 28 69 66 20 2a 74 72 sport). (if *tr
0950: 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 0a 20 20 ansport-type*.
0960: 20 20 20 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 *transport-t
0970: 79 70 65 2a 0a 20 20 20 20 20 20 28 6c 65 74 20 ype*. (let
0980: 28 28 74 74 79 70 65 20 28 73 74 72 69 6e 67 2d ((ttype (string-
0990: 3e 73 79 6d 62 6f 6c 0a 09 09 20 20 20 20 28 6f >symbol... (o
09a0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
09b0: 22 2d 74 72 61 6e 73 70 6f 72 74 22 29 0a 09 09 "-transport")...
09c0: 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 .(configf:lookup
09d0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
09e0: 72 76 65 72 22 20 22 74 72 61 6e 73 70 6f 72 74 rver" "transport
09f0: 22 29 0a 09 09 09 22 72 70 63 22 29 29 29 29 0a ")...."rpc")))).
0a00: 09 28 73 65 74 21 20 2a 74 72 61 6e 73 70 6f 72 .(set! *transpor
0a10: 74 2d 74 79 70 65 2a 20 74 74 79 70 65 29 0a 09 t-type* ttype)..
0a20: 74 74 79 70 65 29 29 29 0a 09 20 20 20 20 0a 3b ttype))).. .;
0a30: 3b 20 47 65 6e 65 72 61 74 65 20 61 20 75 6e 69 ; Generate a uni
0a40: 71 75 65 20 73 69 67 6e 61 74 75 72 65 20 66 6f que signature fo
0a50: 72 20 74 68 69 73 20 73 65 72 76 65 72 0a 28 64 r this server.(d
0a60: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6d 6b efine (server:mk
0a70: 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 6d -signature). (m
0a80: 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 74 essage-digest-st
0a90: 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 74 ring (md5-primit
0aa0: 69 76 65 29 20 0a 09 09 09 20 28 77 69 74 68 2d ive) .... (with-
0ab0: 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 output-to-string
0ac0: 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 61 20 28 .... (lambda (
0ad0: 29 0a 09 09 09 20 20 20 20 20 28 77 72 69 74 65 ).... (write
0ae0: 20 28 6c 69 73 74 20 28 63 75 72 72 65 6e 74 2d (list (current-
0af0: 64 69 72 65 63 74 6f 72 79 29 0a 20 20 20 20 20 directory).
0b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b20: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 (current-pr
0b30: 6f 63 65 73 73 2d 69 64 29 0a 09 09 09 09 09 20 ocess-id)......
0b40: 20 28 61 72 67 76 29 29 29 29 29 29 29 0a 0a 28 (argv)))))))..(
0b50: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 define (server:g
0b60: 65 74 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 et-client-signat
0b70: 75 72 65 29 0a 20 20 28 69 66 20 2a 6d 79 2d 63 ure). (if *my-c
0b80: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature*
0b90: 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e *my-client-sign
0ba0: 61 74 75 72 65 2a 0a 20 20 20 20 20 20 28 6c 65 ature*. (le
0bb0: 74 20 28 28 73 69 67 20 28 73 65 72 76 65 72 3a t ((sig (server:
0bc0: 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 29 29 20 mk-signature)))
0bd0: 3b 3b 20 63 6c 69 65 6e 74 73 20 72 65 2d 75 73 ;; clients re-us
0be0: 65 20 74 68 65 20 73 65 72 76 65 72 3a 6d 6b 2d e the server:mk-
0bf0: 73 69 67 6e 61 74 75 72 65 20 6c 6f 67 69 63 0a signature logic.
0c00: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 2a 6d (set! *m
0c10: 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 y-client-signatu
0c20: 72 65 2a 20 73 69 67 29 0a 20 20 20 20 20 20 20 re* sig).
0c30: 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e *my-client-sign
0c40: 61 74 75 72 65 2a 29 29 29 0a 0a 28 64 65 66 69 ature*)))..(defi
0c50: 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 73 ne (server:get-s
0c60: 65 72 76 65 72 2d 69 64 29 0a 20 20 28 69 66 20 erver-id). (if
0c70: 2a 73 65 72 76 65 72 2d 69 64 2a 20 2a 73 65 72 *server-id* *ser
0c80: 76 65 72 2d 69 64 2a 0a 20 20 20 20 20 20 28 6c ver-id*. (l
0c90: 65 74 20 28 28 73 69 67 20 28 73 65 72 76 65 72 et ((sig (server
0ca0: 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 29 29 :mk-signature)))
0cb0: 20 3b 3b 20 63 6c 69 65 6e 74 73 20 72 65 2d 75 ;; clients re-u
0cc0: 73 65 20 74 68 65 20 73 65 72 76 65 72 3a 6d 6b se the server:mk
0cd0: 2d 73 69 67 6e 61 74 75 72 65 20 6c 6f 67 69 63 -signature logic
0ce0: 0a 20 20 20 20 20 20 20 20 28 73 65 74 21 20 2a . (set! *
0cf0: 73 65 72 76 65 72 2d 69 64 2a 20 73 69 67 29 0a server-id* sig).
0d00: 20 20 20 20 20 20 20 20 2a 73 65 72 76 65 72 2d *server-
0d10: 69 64 2a 29 29 29 0a 0a 3b 3b 20 3b 3b 20 57 68 id*)))..;; ;; Wh
0d20: 65 6e 20 75 73 69 6e 67 20 7a 6d 71 20 74 68 69 en using zmq thi
0d30: 73 20 77 6f 75 6c 64 20 73 65 6e 64 20 74 68 65 s would send the
0d40: 20 6d 65 73 73 61 67 65 20 62 61 63 6b 20 28 74 message back (t
0d50: 77 6f 20 73 74 65 70 20 70 72 6f 63 65 73 73 29 wo step process)
0d60: 0a 3b 3b 20 3b 3b 20 77 69 74 68 20 73 70 69 66 .;; ;; with spif
0d70: 66 79 20 6f 72 20 72 70 63 20 74 68 69 73 20 73 fy or rpc this s
0d80: 69 6d 70 6c 79 20 72 65 74 75 72 6e 73 20 74 68 imply returns th
0d90: 65 20 72 65 74 75 72 6e 20 64 61 74 61 20 74 6f e return data to
0da0: 20 62 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b 20 be returned.;;
0db0: 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;; .;; (define (
0dc0: 73 65 72 76 65 72 3a 72 65 70 6c 79 20 72 65 74 server:reply ret
0dd0: 75 72 6e 2d 61 64 64 72 20 71 75 65 72 79 2d 73 urn-addr query-s
0de0: 69 67 20 73 75 63 63 65 73 73 2f 66 61 69 6c 20 ig success/fail
0df0: 72 65 73 75 6c 74 29 0a 3b 3b 20 20 20 28 64 65 result).;; (de
0e00: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
0e10: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
0e20: 6f 72 74 2a 20 22 73 65 72 76 65 72 3a 72 65 70 ort* "server:rep
0e30: 6c 79 20 72 65 74 75 72 6e 2d 61 64 64 72 3d 22 ly return-addr="
0e40: 20 72 65 74 75 72 6e 2d 61 64 64 72 20 22 2c 20 return-addr ",
0e50: 72 65 73 75 6c 74 3d 22 20 72 65 73 75 6c 74 29 result=" result)
0e60: 0a 3b 3b 20 20 20 3b 3b 20 28 73 65 6e 64 2d 6d .;; ;; (send-m
0e70: 65 73 73 61 67 65 20 70 75 62 73 6f 63 6b 20 74 essage pubsock t
0e80: 61 72 67 65 74 20 73 65 6e 64 2d 6d 6f 72 65 3a arget send-more:
0e90: 20 23 74 29 0a 3b 3b 20 20 20 3b 3b 20 28 73 65 #t).;; ;; (se
0ea0: 6e 64 2d 6d 65 73 73 61 67 65 20 70 75 62 73 6f nd-message pubso
0eb0: 63 6b 20 0a 3b 3b 20 20 20 28 63 61 73 65 20 28 ck .;; (case (
0ec0: 73 65 72 76 65 72 3a 67 65 74 2d 74 72 61 6e 73 server:get-trans
0ed0: 70 6f 72 74 29 0a 3b 3b 20 20 20 20 20 28 28 72 port).;; ((r
0ee0: 70 63 29 20 20 28 64 62 3a 6f 62 6a 2d 3e 73 74 pc) (db:obj->st
0ef0: 72 69 6e 67 20 28 76 65 63 74 6f 72 20 73 75 63 ring (vector suc
0f00: 63 65 73 73 2f 66 61 69 6c 20 71 75 65 72 79 2d cess/fail query-
0f10: 73 69 67 20 72 65 73 75 6c 74 29 29 29 0a 3b 3b sig result))).;;
0f20: 20 20 20 20 20 28 28 68 74 74 70 29 20 28 64 62 ((http) (db
0f30: 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 28 76 65 :obj->string (ve
0f40: 63 74 6f 72 20 73 75 63 63 65 73 73 2f 66 61 69 ctor success/fai
0f50: 6c 20 71 75 65 72 79 2d 73 69 67 20 72 65 73 75 l query-sig resu
0f60: 6c 74 29 29 29 0a 3b 3b 20 20 20 20 20 28 28 66 lt))).;; ((f
0f70: 73 29 20 20 20 72 65 73 75 6c 74 29 0a 3b 3b 20 s) result).;;
0f80: 20 20 20 20 28 65 6c 73 65 20 0a 3b 3b 20 20 20 (else .;;
0f90: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
0fa0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
0fb0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 75 6e 72 65 -log-port* "unre
0fc0: 63 6f 67 6e 69 73 65 64 20 74 72 61 6e 73 70 6f cognised transpo
0fd0: 72 74 20 74 79 70 65 3a 20 22 20 2a 74 72 61 6e rt type: " *tran
0fe0: 73 70 6f 72 74 2d 74 79 70 65 2a 29 0a 3b 3b 20 sport-type*).;;
0ff0: 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a 0a result)))..
1000: 3b 3b 20 47 69 76 65 6e 20 61 6e 20 61 72 65 61 ;; Given an area
1010: 20 70 61 74 68 2c 20 20 73 74 61 72 74 20 61 20 path, start a
1020: 73 65 72 76 65 72 20 70 72 6f 63 65 73 73 20 20 server process
1030: 20 20 23 23 23 20 4e 4f 54 45 20 23 23 23 20 3e ### NOTE ### >
1040: 20 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 69 file 2>&1 .;; i
1050: 66 20 74 68 65 20 74 61 72 67 65 74 2d 68 6f 73 f the target-hos
1060: 74 20 69 73 20 73 65 74 20 0a 3b 3b 20 74 72 79 t is set .;; try
1070: 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 68 61 74 running on that
1080: 20 68 6f 73 74 0a 3b 3b 20 20 20 69 6e 63 69 64 host.;; incid
1090: 65 6e 74 61 6c 3a 20 72 6f 74 61 74 65 20 6c 6f ental: rotate lo
10a0: 67 73 20 69 6e 20 6c 6f 67 73 2f 20 64 69 72 2e gs in logs/ dir.
10b0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 20 28 73 65 .;;.(define (se
10c0: 72 76 65 72 3a 72 75 6e 20 61 72 65 61 70 61 74 rver:run areapat
10d0: 68 29 20 3b 3b 20 61 72 65 61 70 61 74 68 20 69 h) ;; areapath i
10e0: 73 20 2a 74 6f 70 70 61 74 68 2a 20 66 6f 72 20 s *toppath* for
10f0: 61 20 67 69 76 65 6e 20 74 65 73 74 73 75 69 74 a given testsuit
1100: 65 20 61 72 65 61 0a 20 20 28 6c 65 74 2a 20 28 e area. (let* (
1110: 28 74 65 73 74 73 75 69 74 65 20 20 20 28 63 6f (testsuite (co
1120: 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 mmon:get-testsui
1130: 74 65 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 te-name)).. (log
1140: 66 69 6c 65 20 20 20 20 20 28 63 6f 6e 63 20 61 file (conc a
1150: 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 2f 73 reapath "/logs/s
1160: 65 72 76 65 72 2e 6c 6f 67 22 29 29 20 3b 3b 20 erver.log")) ;;
1170: 2d 22 20 63 75 72 72 2d 70 69 64 20 22 2d 22 20 -" curr-pid "-"
1180: 74 61 72 67 65 74 2d 68 6f 73 74 20 22 2e 6c 6f target-host ".lo
1190: 67 22 29 29 0a 09 20 28 70 72 6f 66 69 6c 65 2d g")).. (profile-
11a0: 6d 6f 64 65 20 28 6f 72 20 28 63 6f 6e 66 69 67 mode (or (config
11b0: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
11c0: 64 61 74 2a 20 22 6d 69 73 63 22 20 22 70 72 6f dat* "misc" "pro
11d0: 66 69 6c 65 73 77 22 29 0a 09 09 09 20 20 20 22 filesw").... "
11e0: 22 29 29 0a 09 20 28 63 6d 64 6c 6e 20 28 63 6f ")).. (cmdln (co
11f0: 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d nc (common:get-m
1200: 65 67 61 74 65 73 74 2d 65 78 65 29 0a 09 09 20 egatest-exe)...
1210: 20 20 20 20 20 22 20 2d 73 65 72 76 65 72 20 2d " -server -
1220: 20 22 3b 3b 20 28 6f 72 20 74 61 72 67 65 74 2d ";; (or target-
1230: 68 6f 73 74 20 22 2d 22 29 0a 09 09 20 20 20 20 host "-")...
1240: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 (if (equal? (c
1250: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
1260: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 onfigdat* "serve
1270: 72 22 20 22 64 61 65 6d 6f 6e 69 7a 65 22 29 20 r" "daemonize")
1280: 22 79 65 73 22 29 0a 09 09 09 20 20 22 20 2d 64 "yes").... " -d
1290: 61 65 6d 6f 6e 69 7a 65 20 22 0a 09 09 09 20 20 aemonize "....
12a0: 22 22 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 22 "")... ;; "
12b0: 20 2d 6c 6f 67 20 22 20 6c 6f 67 66 69 6c 65 0a -log " logfile.
12c0: 09 09 20 20 20 20 20 20 22 20 2d 6d 20 74 65 73 .. " -m tes
12d0: 74 73 75 69 74 65 3a 22 20 74 65 73 74 73 75 69 tsuite:" testsui
12e0: 74 65 0a 09 09 20 20 20 20 20 20 22 20 22 20 70 te... " " p
12f0: 72 6f 66 69 6c 65 2d 6d 6f 64 65 0a 09 09 20 20 rofile-mode...
1300: 20 20 20 20 29 29 20 3b 3b 20 28 63 6f 6e 63 20 )) ;; (conc
1310: 22 20 3e 3e 20 22 20 6c 6f 67 66 69 6c 65 20 22 " >> " logfile "
1320: 20 32 3e 26 31 20 26 22 29 29 29 29 29 0a 09 20 2>&1 &")))))..
1330: 28 6c 6f 67 2d 72 6f 74 61 74 65 20 20 28 6d 61 (log-rotate (ma
1340: 6b 65 2d 74 68 72 65 61 64 20 63 6f 6d 6d 6f 6e ke-thread common
1350: 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 20 20 22 73 :rotate-logs "s
1360: 65 72 76 65 72 20 72 75 6e 2c 20 72 6f 74 61 74 erver run, rotat
1370: 65 20 6c 6f 67 73 20 74 68 72 65 61 64 22 29 29 e logs thread"))
1380: 20 3b 3b 20 77 68 79 20 61 72 65 20 77 65 20 72 ;; why are we r
1390: 6f 74 61 74 69 6e 67 20 6c 6f 67 73 20 68 65 72 otating logs her
13a0: 65 3f 20 54 68 69 73 20 69 73 20 61 20 73 65 6e e? This is a sen
13b0: 73 69 74 69 76 65 20 6c 6f 63 61 74 69 6f 6e 20 sitive location
13c0: 77 69 74 68 20 61 20 6c 6f 74 20 67 6f 69 6e 67 with a lot going
13d0: 20 6f 6e 21 3f 0a 20 20 20 20 20 20 20 20 20 28 on!?. (
13e0: 6c 6f 61 64 2d 6c 69 6d 69 74 20 20 28 63 6f 6e load-limit (con
13f0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 figf:lookup-numb
1400: 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 er *configdat* "
1410: 6a 6f 62 74 6f 6f 6c 73 22 20 22 6d 61 78 2d 73 jobtools" "max-s
1420: 65 72 76 65 72 2d 73 74 61 72 74 2d 6c 6f 61 64 erver-start-load
1430: 22 20 64 65 66 61 75 6c 74 3a 20 33 2e 30 29 29 " default: 3.0))
1440: 29 0a 20 20 20 20 3b 3b 20 77 65 20 77 61 6e 74 ). ;; we want
1450: 20 74 68 65 20 72 65 6d 6f 74 65 20 73 65 72 76 the remote serv
1460: 65 72 20 74 6f 20 73 74 61 72 74 20 69 6e 20 2a er to start in *
1470: 74 6f 70 70 61 74 68 2a 20 73 6f 20 70 75 73 68 toppath* so push
1480: 20 74 68 65 72 65 0a 20 20 20 20 28 70 75 73 68 there. (push
1490: 2d 64 69 72 65 63 74 6f 72 79 20 61 72 65 61 70 -directory areap
14a0: 61 74 68 29 0a 20 20 20 20 28 64 65 62 75 67 3a ath). (debug:
14b0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
14c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
14d0: 3a 20 54 72 79 69 6e 67 20 74 6f 20 73 74 61 72 : Trying to star
14e0: 74 20 73 65 72 76 65 72 20 28 22 20 63 6d 64 6c t server (" cmdl
14f0: 6e 20 22 29 20 2e 2e 2e 22 29 0a 20 20 20 20 28 n ") ..."). (
1500: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 6c 6f thread-start! lo
1510: 67 2d 72 6f 74 61 74 65 29 0a 20 20 20 20 0a 20 g-rotate). .
1520: 20 20 20 3b 3b 20 68 6f 73 74 2e 64 6f 6d 61 69 ;; host.domai
1530: 6e 2e 74 6c 64 20 6d 61 74 63 68 20 68 6f 73 74 n.tld match host
1540: 3f 0a 20 20 20 20 3b 3b 20 28 69 66 20 28 61 6e ?. ;; (if (an
1550: 64 20 74 61 72 67 65 74 2d 68 6f 73 74 20 0a 20 d target-host .
1560: 20 20 20 3b 3b 20 09 20 20 20 20 20 3b 3b 20 6c ;; . ;; l
1570: 6f 6f 6b 20 61 74 20 74 61 72 67 65 74 20 68 6f ook at target ho
1580: 73 74 2c 20 69 73 20 69 74 20 68 6f 73 74 2e 64 st, is it host.d
1590: 6f 6d 61 69 6e 2e 74 6c 64 20 6f 72 20 69 70 20 omain.tld or ip
15a0: 61 64 64 72 65 73 73 20 61 6e 64 20 64 6f 65 73 address and does
15b0: 20 69 74 20 0a 20 20 20 20 3b 3b 20 09 20 20 20 it . ;; .
15c0: 20 20 3b 3b 20 6d 61 74 63 68 20 63 75 72 72 65 ;; match curre
15d0: 6e 74 20 69 70 20 6f 72 20 68 6f 73 74 6e 61 6d nt ip or hostnam
15e0: 65 0a 20 20 20 20 3b 3b 20 09 20 20 20 20 20 28 e. ;; . (
15f0: 6e 6f 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 not (string-matc
1600: 68 20 28 63 6f 6e 63 20 22 28 22 63 75 72 72 2d h (conc "("curr-
1610: 68 6f 73 74 20 22 7c 22 20 63 75 72 72 2d 68 6f host "|" curr-ho
1620: 73 74 22 5c 5c 2e 2e 2a 29 22 29 20 74 61 72 67 st"\\..*)") targ
1630: 65 74 2d 68 6f 73 74 29 29 0a 20 20 20 20 3b 3b et-host)). ;;
1640: 20 09 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 . (not (equ
1650: 61 6c 3f 20 63 75 72 72 2d 69 70 20 74 61 72 67 al? curr-ip targ
1660: 65 74 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 3b et-host))). ;
1670: 3b 20 09 28 62 65 67 69 6e 0a 20 20 20 20 3b 3b ; .(begin. ;;
1680: 20 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
1690: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
16a0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 72 -log-port* "Star
16b0: 74 69 6e 67 20 73 65 72 76 65 72 20 6f 6e 20 22 ting server on "
16c0: 20 74 61 72 67 65 74 2d 68 6f 73 74 20 22 2c 20 target-host ",
16d0: 6c 6f 67 66 69 6c 65 20 69 73 20 22 20 6c 6f 67 logfile is " log
16e0: 66 69 6c 65 29 0a 20 20 20 20 3b 3b 20 09 20 20 file). ;; .
16f0: 28 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 (setenv "TARGETH
1700: 4f 53 54 22 20 74 61 72 67 65 74 2d 68 6f 73 74 OST" target-host
1710: 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 0a 20 20 ))). ;; .
1720: 20 20 28 73 65 74 65 6e 76 20 22 54 41 52 47 45 (setenv "TARGE
1730: 54 48 4f 53 54 5f 4c 4f 47 46 22 20 6c 6f 67 66 THOST_LOGF" logf
1740: 69 6c 65 29 0a 20 20 20 20 28 74 68 72 65 61 64 ile). (thread
1750: 2d 73 6c 65 65 70 21 20 28 2f 20 28 72 61 6e 64 -sleep! (/ (rand
1760: 6f 6d 20 33 30 30 30 29 20 31 30 30 30 29 29 20 om 3000) 1000))
1770: 3b 3b 20 61 64 64 20 61 20 72 61 6e 64 6f 6d 20 ;; add a random
1780: 69 6e 69 74 69 61 6c 20 64 65 6c 61 79 2e 20 49 initial delay. I
1790: 74 20 73 65 65 6d 73 20 70 72 65 74 74 79 20 63 t seems pretty c
17a0: 6f 6d 6d 6f 6e 20 74 68 61 74 20 6d 61 6e 79 20 ommon that many
17b0: 72 75 6e 6e 69 6e 67 20 74 65 73 74 73 20 72 65 running tests re
17c0: 71 75 65 73 74 20 61 20 73 65 72 76 65 72 20 61 quest a server a
17d0: 74 20 74 68 65 20 73 61 6d 65 20 74 69 6d 65 0a t the same time.
17e0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
17f0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1800: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 73 74 61 port* "INFO: sta
1810: 72 74 69 6e 67 20 73 65 72 76 65 72 20 61 74 20 rting server at
1820: 22 20 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d " (common:human-
1830: 74 69 6d 65 29 29 0a 20 20 20 20 28 73 79 73 74 time)). (syst
1840: 65 6d 20 28 63 6f 6e 63 20 22 6e 62 66 61 6b 65 em (conc "nbfake
1850: 20 22 20 63 6d 64 6c 6e 29 29 0a 20 20 20 20 28 " cmdln)). (
1860: 75 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 unsetenv "TARGET
1870: 48 4f 53 54 5f 4c 4f 47 46 22 29 0a 20 20 20 20 HOST_LOGF").
1880: 3b 3b 20 28 69 66 20 28 67 65 74 2d 65 6e 76 69 ;; (if (get-envi
1890: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
18a0: 20 22 54 41 52 47 45 54 48 4f 53 54 22 29 28 75 "TARGETHOST")(u
18b0: 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 nsetenv "TARGETH
18c0: 4f 53 54 22 29 29 0a 20 20 20 20 28 74 68 72 65 OST")). (thre
18d0: 61 64 2d 6a 6f 69 6e 21 20 6c 6f 67 2d 72 6f 74 ad-join! log-rot
18e0: 61 74 65 29 0a 20 20 20 20 28 70 6f 70 2d 64 69 ate). (pop-di
18f0: 72 65 63 74 6f 72 79 29 29 29 0a 0a 0a 28 64 65 rectory)))...(de
1900: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6c 6f 67 fine (server:log
1910: 66 2d 67 65 74 2d 73 74 61 72 74 2d 69 6e 66 6f f-get-start-info
1920: 20 6c 6f 67 66 29 0a 20 20 28 6c 65 74 20 28 28 logf). (let ((
1930: 73 65 72 76 65 72 2d 72 78 20 20 20 20 28 72 65 server-rx (re
1940: 67 65 78 70 20 22 5e 53 45 52 56 45 52 20 53 54 gexp "^SERVER ST
1950: 41 52 54 45 44 3a 20 28 5c 5c 53 2b 29 3a 28 5c ARTED: (\\S+):(\
1960: 5c 64 2b 29 20 41 54 20 28 5b 5c 5c 64 5c 5c 2e \d+) AT ([\\d\\.
1970: 5d 2b 29 20 73 65 72 76 65 72 2d 69 64 3a 20 28 ]+) server-id: (
1980: 5c 5c 53 2b 29 20 70 69 64 3a 20 28 5c 5c 64 2b \\S+) pid: (\\d+
1990: 29 22 29 29 20 3b 3b 20 53 45 52 56 45 52 20 53 )")) ;; SERVER S
19a0: 54 41 52 54 45 44 3a 20 68 6f 73 74 3a 70 6f 72 TARTED: host:por
19b0: 74 20 41 54 20 74 69 6d 65 73 65 63 73 20 73 65 t AT timesecs se
19c0: 72 76 65 72 20 69 64 0a 20 20 20 20 20 20 20 20 rver id.
19d0: 28 64 62 70 72 65 70 2d 72 78 20 20 20 20 28 72 (dbprep-rx (r
19e0: 65 67 65 78 70 20 22 5e 53 45 52 56 45 52 3a 20 egexp "^SERVER:
19f0: 64 62 70 72 65 70 22 29 29 0a 20 20 20 20 20 20 dbprep")).
1a00: 20 20 28 64 62 70 72 65 70 2d 66 6f 75 6e 64 20 (dbprep-found
1a10: 30 29 0a 09 28 62 61 64 2d 64 61 74 20 20 20 20 0)..(bad-dat
1a20: 20 20 28 6c 69 73 74 20 23 66 20 23 66 20 23 66 (list #f #f #f
1a30: 20 23 66 20 23 66 29 29 29 0a 20 20 20 20 28 68 #f #f))). (h
1a40: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
1a50: 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 . exn. (
1a60: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 3b 3b 20 begin. ;;
1a70: 57 41 52 4e 49 4e 47 3a 20 74 68 69 73 20 69 73 WARNING: this is
1a80: 20 70 6f 74 65 6e 74 69 61 6c 6c 79 20 64 61 6e potentially dan
1a90: 67 65 72 6f 75 73 20 74 6f 20 62 6c 61 6e 6b 65 gerous to blanke
1aa0: 74 20 69 67 6e 6f 72 65 20 74 68 65 20 65 72 72 t ignore the err
1ab0: 6f 72 73 0a 20 20 20 20 20 20 20 28 69 66 20 28 ors. (if (
1ac0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c 6f 67 file-exists? log
1ad0: 66 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 f).. (debug:pr
1ae0: 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 int-info 2 *defa
1af0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 ult-log-port* "U
1b00: 6e 61 62 6c 65 20 74 6f 20 67 65 74 20 73 65 72 nable to get ser
1b10: 76 65 72 20 69 6e 66 6f 20 66 72 6f 6d 20 22 6c ver info from "l
1b20: 6f 67 66 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 ogf", exn=" exn)
1b30: 29 0a 20 20 20 20 20 20 20 62 61 64 2d 64 61 74 ). bad-dat
1b40: 29 20 3b 3b 20 6e 6f 20 69 64 65 61 20 77 68 61 ) ;; no idea wha
1b50: 74 20 77 65 6e 74 20 77 72 6f 6e 67 2c 20 63 61 t went wrong, ca
1b60: 6c 6c 20 69 74 20 61 20 62 61 64 20 73 65 72 76 ll it a bad serv
1b70: 65 72 0a 20 20 20 20 20 28 77 69 74 68 2d 69 6e er. (with-in
1b80: 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 0a 09 20 put-from-file..
1b90: 6c 6f 67 66 0a 20 20 20 20 20 20 20 28 6c 61 6d logf. (lam
1ba0: 62 64 61 20 28 29 0a 09 20 28 6c 65 74 20 6c 6f bda ().. (let lo
1bb0: 6f 70 20 28 28 69 6e 6c 20 20 28 72 65 61 64 2d op ((inl (read-
1bc0: 6c 69 6e 65 29 29 0a 09 09 20 20 20 20 28 6c 6e line))... (ln
1bd0: 75 6d 20 30 29 29 0a 09 20 20 20 28 69 66 20 28 um 0)).. (if (
1be0: 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f not (eof-object?
1bf0: 20 69 6e 6c 29 29 0a 09 20 20 20 20 20 20 20 28 inl)).. (
1c00: 6c 65 74 20 28 28 6d 6c 73 74 20 28 73 74 72 69 let ((mlst (stri
1c10: 6e 67 2d 6d 61 74 63 68 20 73 65 72 76 65 72 2d ng-match server-
1c20: 72 78 20 69 6e 6c 29 29 0a 09 09 20 20 20 20 20 rx inl))...
1c30: 28 64 62 70 72 65 70 20 28 73 74 72 69 6e 67 2d (dbprep (string-
1c40: 6d 61 74 63 68 20 64 62 70 72 65 70 2d 72 78 20 match dbprep-rx
1c50: 69 6e 6c 29 29 29 0a 09 09 20 28 69 66 20 64 62 inl)))... (if db
1c60: 70 72 65 70 20 28 73 65 74 21 20 64 62 70 72 65 prep (set! dbpre
1c70: 70 2d 66 6f 75 6e 64 20 31 29 29 0a 09 09 20 28 p-found 1))... (
1c80: 69 66 20 28 6e 6f 74 20 6d 6c 73 74 29 0a 09 09 if (not mlst)...
1c90: 20 20 20 20 20 28 69 66 20 28 3c 20 6c 6e 75 6d (if (< lnum
1ca0: 20 35 30 30 29 20 3b 3b 20 67 69 76 65 20 75 70 500) ;; give up
1cb0: 20 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 35 30 if more than 50
1cc0: 30 20 6c 69 6e 65 73 20 6f 66 20 73 65 72 76 65 0 lines of serve
1cd0: 72 20 6c 6f 67 20 72 65 61 64 0a 09 09 09 20 28 r log read.... (
1ce0: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
1cf0: 28 2b 20 6c 6e 75 6d 20 31 29 29 0a 09 09 09 20 (+ lnum 1))....
1d00: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin .
1d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d20: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1d30: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
1d40: 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 61 62 6c log-port* "Unabl
1d50: 65 20 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 e to get server
1d60: 69 6e 66 6f 20 66 72 6f 6d 20 66 69 72 73 74 20 info from first
1d70: 35 30 30 20 6c 69 6e 65 73 20 6f 66 20 22 20 6c 500 lines of " l
1d80: 6f 67 66 20 29 0a 20 20 20 20 20 20 20 20 20 20 ogf ).
1d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1da0: 20 62 61 64 2d 64 61 74 29 29 0a 09 09 20 20 20 bad-dat))...
1db0: 20 20 28 6d 61 74 63 68 20 6d 6c 73 74 0a 09 09 (match mlst...
1dc0: 09 20 20 20 20 28 28 5f 20 68 6f 73 74 20 70 6f . ((_ host po
1dd0: 72 74 20 73 74 61 72 74 20 73 65 72 76 65 72 2d rt start server-
1de0: 69 64 20 70 69 64 29 0a 09 09 09 20 20 20 20 20 id pid)....
1df0: 28 6c 69 73 74 20 68 6f 73 74 0a 09 09 09 09 20 (list host.....
1e00: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
1e10: 72 20 70 6f 72 74 29 0a 09 09 09 09 20 20 20 28 r port)..... (
1e20: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 73 string->number s
1e30: 74 61 72 74 29 0a 09 09 09 09 20 20 20 73 65 72 tart)..... ser
1e40: 76 65 72 2d 69 64 0a 09 09 09 09 20 20 20 28 73 ver-id..... (s
1e50: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 69 tring->number pi
1e60: 64 29 29 29 0a 09 09 09 20 20 20 20 28 65 6c 73 d))).... (els
1e70: 65 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 67 e.... (debug
1e80: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
1e90: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 t-log-port* "ERR
1ea0: 4f 52 3a 20 64 69 64 20 6e 6f 74 20 72 65 63 6f OR: did not reco
1eb0: 67 6e 69 73 65 20 53 45 52 56 45 52 20 6c 69 6e gnise SERVER lin
1ec0: 65 20 69 6e 66 6f 20 22 6d 6c 73 74 29 0a 09 09 e info "mlst)...
1ed0: 09 20 20 20 20 20 62 61 64 2d 64 61 74 29 29 29 . bad-dat)))
1ee0: 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ).. (begin
1ef0: 20 0a 09 09 20 28 69 66 20 64 62 70 72 65 70 2d ... (if dbprep-
1f00: 66 6f 75 6e 64 0a 09 09 20 20 20 20 20 28 62 65 found... (be
1f10: 67 69 6e 0a 09 09 20 20 20 20 20 20 20 28 64 65 gin... (de
1f20: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
1f30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1f40: 72 74 2a 20 22 53 65 72 76 65 72 20 69 73 20 69 rt* "Server is i
1f50: 6e 20 64 62 70 72 65 70 20 61 74 20 22 20 28 63 n dbprep at " (c
1f60: 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 ommon:human-time
1f70: 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 68 72 ))... (thr
1f80: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 29 ead-sleep! 0.5))
1f90: 20 3b 3b 20 77 61 73 20 32 35 20 73 65 63 20 62 ;; was 25 sec b
1fa0: 75 74 20 74 68 61 74 20 62 6c 6f 63 6b 65 64 20 ut that blocked
1fb0: 74 68 69 6e 67 73 20 66 72 6f 6d 20 73 74 61 72 things from star
1fc0: 74 69 6e 67 3f 0a 09 09 20 20 20 20 20 28 64 65 ting?... (de
1fd0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
1fe0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1ff0: 72 74 2a 20 22 55 6e 61 62 6c 65 20 74 6f 20 67 rt* "Unable to g
2000: 65 74 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 et server info f
2010: 72 6f 6d 20 22 20 6c 6f 67 66 20 22 20 61 74 20 rom " logf " at
2020: 22 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 " (seconds->time
2030: 2d 73 74 72 69 6e 67 20 28 63 75 72 72 65 6e 74 -string (current
2040: 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 09 09 20 -seconds))))...
2050: 62 61 64 2d 64 61 74 29 29 29 29 29 29 29 29 0a bad-dat)))))))).
2060: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 ..(define (serve
2070: 72 3a 72 65 63 6f 72 64 2d 3e 69 64 20 73 65 72 r:record->id ser
2080: 76 72 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 vr). (handle-ex
2090: 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a ceptions. exn.
20a0: 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 (begin .
20b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
20c0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
20d0: 2d 70 6f 72 74 2a 20 20 22 55 6e 61 62 6c 65 20 -port* "Unable
20e0: 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 69 64 to get server id
20f0: 20 66 72 6f 6d 20 22 20 73 65 72 76 72 20 22 2c from " servr ",
2100: 20 65 78 6e 3d 22 20 65 78 6e 29 20 20 20 20 20 exn=" exn)
2110: 0a 20 20 20 23 66 29 0a 20 20 28 6d 61 74 63 68 . #f). (match
2120: 2d 6c 65 74 20 28 28 28 68 6f 73 74 20 70 6f 72 -let (((host por
2130: 74 20 73 74 61 72 74 2d 74 69 6d 65 20 73 65 72 t start-time ser
2140: 76 65 72 2d 69 64 20 70 69 64 29 0a 09 20 20 20 ver-id pid)..
2150: 20 20 20 20 73 65 72 76 72 29 29 0a 20 20 20 20 servr)).
2160: 28 69 66 20 73 65 72 76 65 72 2d 69 64 0a 09 73 (if server-id..s
2170: 65 72 76 65 72 2d 69 64 0a 09 23 66 29 29 29 29 erver-id..#f))))
2180: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 ..(define (serve
2190: 72 3a 72 65 63 6f 72 64 2d 3e 75 72 6c 20 73 65 r:record->url se
21a0: 72 76 72 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 rvr). (handle-e
21b0: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e xceptions. exn
21c0: 0a 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 . (begin .
21d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
21e0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
21f0: 67 2d 70 6f 72 74 2a 20 20 22 55 6e 61 62 6c 65 g-port* "Unable
2200: 20 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 75 to get server u
2210: 72 6c 20 66 72 6f 6d 20 22 20 73 65 72 76 72 20 rl from " servr
2220: 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 20 20 20 ", exn=" exn)
2230: 20 20 0a 20 20 20 23 66 29 0a 20 20 28 6d 61 74 . #f). (mat
2240: 63 68 2d 6c 65 74 20 28 28 28 68 6f 73 74 20 70 ch-let (((host p
2250: 6f 72 74 20 73 74 61 72 74 2d 74 69 6d 65 20 73 ort start-time s
2260: 65 72 76 65 72 2d 69 64 20 70 69 64 29 0a 09 20 erver-id pid)..
2270: 20 20 20 20 20 20 73 65 72 76 72 29 29 0a 20 20 servr)).
2280: 20 20 28 69 66 20 28 61 6e 64 20 68 6f 73 74 20 (if (and host
2290: 70 6f 72 74 29 0a 09 28 63 6f 6e 63 20 68 6f 73 port)..(conc hos
22a0: 74 20 22 3a 22 20 70 6f 72 74 29 0a 09 23 66 29 t ":" port)..#f)
22b0: 29 29 29 0a 0a 3b 3b 20 6f 6c 64 65 73 74 20 73 )))..;; oldest s
22c0: 65 72 76 65 72 20 61 6c 69 76 65 20 64 65 74 65 erver alive dete
22d0: 72 6d 69 6e 65 73 20 68 6f 73 74 20 74 68 65 6e rmines host then
22e0: 20 63 68 6f 6f 73 65 20 72 61 6e 64 6f 6d 20 6f choose random o
22f0: 66 20 79 6f 75 6e 67 65 73 74 0a 3b 3b 20 66 69 f youngest.;; fi
2300: 76 65 20 73 65 72 76 65 72 73 20 6f 6e 20 74 68 ve servers on th
2310: 61 74 20 68 6f 73 74 0a 3b 3b 0a 28 64 65 66 69 at host.;;.(defi
2320: 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 73 ne (server:get-s
2330: 65 72 76 65 72 73 2d 69 6e 66 6f 20 61 72 65 61 ervers-info area
2340: 70 61 74 68 29 0a 20 20 3b 3b 20 28 61 73 73 65 path). ;; (asse
2350: 72 74 20 2a 74 6f 70 70 61 74 68 2a 20 22 46 41 rt *toppath* "FA
2360: 54 41 4c 3a 20 73 65 72 76 65 72 3a 67 65 74 2d TAL: server:get-
2370: 73 65 72 76 65 72 73 2d 69 6e 66 6f 20 63 61 6c servers-info cal
2380: 6c 65 64 20 62 65 66 6f 72 65 20 2a 74 6f 70 70 led before *topp
2390: 61 74 68 2a 20 68 61 73 20 62 65 65 6e 20 73 65 ath* has been se
23a0: 74 2e 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 t."). (let* ((s
23b0: 65 72 76 69 6e 66 6f 64 69 72 20 28 73 65 72 76 ervinfodir (serv
23c0: 65 72 3a 67 65 74 2d 73 65 72 76 69 6e 66 6f 2d er:get-servinfo-
23d0: 64 69 72 20 61 72 65 61 70 61 74 68 29 29 29 20 dir areapath)))
23e0: 3b 3b 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 ;; (conc *toppat
23f0: 68 2a 22 2f 2e 73 65 72 76 69 6e 66 6f 22 29 29 h*"/.servinfo"))
2400: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
2410: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 65 72 file-exists? ser
2420: 76 69 6e 66 6f 64 69 72 29 29 0a 09 28 63 72 65 vinfodir))..(cre
2430: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 73 65 ate-directory se
2440: 72 76 69 6e 66 6f 64 69 72 29 29 0a 20 20 20 20 rvinfodir)).
2450: 28 6c 65 74 2a 20 28 28 61 6c 6c 66 69 6c 65 73 (let* ((allfiles
2460: 20 20 20 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 (glob (conc
2470: 73 65 72 76 69 6e 66 6f 64 69 72 22 2f 2a 22 29 servinfodir"/*")
2480: 29 29 0a 09 20 20 20 28 72 65 73 20 20 20 20 20 )).. (res
2490: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
24a0: 61 62 6c 65 29 29 29 0a 20 20 20 20 20 20 28 66 able))). (f
24b0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 20 28 or-each. (
24c0: 6c 61 6d 62 64 61 20 28 66 29 0a 09 20 28 6c 65 lambda (f).. (le
24d0: 74 2a 20 28 28 68 6f 73 74 70 6f 72 74 20 20 28 t* ((hostport (
24e0: 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 70 2d 64 pathname-strip-d
24f0: 69 72 65 63 74 6f 72 79 20 66 29 29 0a 09 09 28 irectory f))...(
2500: 73 65 72 76 65 72 64 61 74 20 28 73 65 72 76 65 serverdat (serve
2510: 72 3a 6c 6f 67 66 2d 67 65 74 2d 73 74 61 72 74 r:logf-get-start
2520: 2d 69 6e 66 6f 20 66 29 29 29 0a 09 20 20 20 28 -info f))).. (
2530: 6d 61 74 63 68 20 73 65 72 76 65 72 64 61 74 0a match serverdat.
2540: 09 20 20 20 20 20 28 28 68 6f 73 74 20 70 6f 72 . ((host por
2550: 74 20 73 74 61 72 74 20 73 65 72 76 65 72 2d 69 t start server-i
2560: 64 20 70 69 64 29 0a 09 20 20 20 20 20 20 28 69 d pid).. (i
2570: 66 20 28 61 6e 64 20 68 6f 73 74 20 70 6f 72 74 f (and host port
2580: 20 73 74 61 72 74 20 73 65 72 76 65 72 2d 69 64 start server-id
2590: 20 70 69 64 29 0a 09 09 20 20 28 68 61 73 68 2d pid)... (hash-
25a0: 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 20 68 table-set! res h
25b0: 6f 73 74 70 6f 72 74 20 73 65 72 76 65 72 64 61 ostport serverda
25c0: 74 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 t)... (debug:pr
25d0: 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 int-info 2 *defa
25e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 ult-log-port* "b
25f0: 61 64 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 ad server info f
2600: 6f 72 20 22 66 22 3a 20 22 73 65 72 76 65 72 64 or "f": "serverd
2610: 61 74 29 29 29 0a 09 20 20 20 20 20 28 65 6c 73 at))).. (els
2620: 65 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a e.. (debug:
2630: 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 print-info 2 *de
2640: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2650: 22 62 61 64 20 73 65 72 76 65 72 20 69 6e 66 6f "bad server info
2660: 20 66 6f 72 20 22 66 22 3a 20 22 73 65 72 76 65 for "f": "serve
2670: 72 64 61 74 29 29 29 29 29 0a 20 20 20 20 20 20 rdat))))).
2680: 20 61 6c 6c 66 69 6c 65 73 29 0a 20 20 20 20 20 allfiles).
2690: 20 72 65 73 29 29 29 0a 0a 3b 3b 20 63 68 65 63 res)))..;; chec
26a0: 6b 20 74 68 65 20 2e 73 65 72 76 69 6e 66 6f 20 k the .servinfo
26b0: 64 69 72 65 63 74 6f 72 79 2c 20 61 72 65 20 74 directory, are t
26c0: 68 65 72 65 20 6f 74 68 65 72 20 73 65 72 76 65 here other serve
26d0: 72 73 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 68 rs running on th
26e0: 69 73 0a 3b 3b 20 6f 72 20 61 6e 6f 74 68 65 72 is.;; or another
26f0: 20 68 6f 73 74 3f 0a 3b 3b 0a 3b 3b 20 72 65 74 host?.;;.;; ret
2700: 75 72 6e 73 20 23 74 20 3d 3e 20 6f 6b 20 74 6f urns #t => ok to
2710: 20 73 74 61 72 74 20 61 6e 6f 74 68 65 72 20 73 start another s
2720: 65 72 76 65 72 0a 3b 3b 20 20 20 20 20 20 20 20 erver.;;
2730: 20 23 66 20 3d 3e 20 6e 6f 74 20 6f 6b 20 74 6f #f => not ok to
2740: 20 73 74 61 72 74 20 61 6e 6f 74 68 65 72 20 73 start another s
2750: 65 72 76 65 72 0a 3b 3b 0a 3b 3b 20 28 64 65 66 erver.;;.;; (def
2760: 69 6e 65 20 28 73 65 72 76 65 72 3a 6d 69 6e 69 ine (server:mini
2770: 6d 61 6c 2d 63 68 65 63 6b 20 61 72 65 61 70 61 mal-check areapa
2780: 74 68 29 0a 3b 3b 20 20 20 28 73 65 72 76 65 72 th).;; (server
2790: 3a 63 6c 65 61 6e 2d 75 70 2d 6f 6c 64 20 61 72 :clean-up-old ar
27a0: 65 61 70 61 74 68 29 0a 3b 3b 20 20 20 28 6c 65 eapath).;; (le
27b0: 74 2a 20 28 28 73 72 76 64 69 72 20 20 20 20 20 t* ((srvdir
27c0: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 73 65 72 (server:get-ser
27d0: 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 61 vinfo-dir areapa
27e0: 74 68 29 29 20 3b 3b 20 28 63 6f 6e 63 20 61 72 th)) ;; (conc ar
27f0: 65 61 70 61 74 68 22 2f 2e 73 65 72 76 69 6e 66 eapath"/.servinf
2800: 6f 22 29 29 0a 3b 3b 20 09 20 28 73 65 72 76 72 o")).;; . (servr
2810: 73 20 20 20 20 20 20 28 67 6c 6f 62 20 28 63 6f s (glob (co
2820: 6e 63 20 73 72 76 64 69 72 22 2f 2a 22 29 29 29 nc srvdir"/*")))
2830: 0a 3b 3b 20 09 20 28 74 68 69 73 68 6f 73 74 69 .;; . (thishosti
2840: 70 20 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 p (server:get-b
2850: 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 est-guess-addres
2860: 73 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 s (get-host-name
2870: 29 29 29 0a 3b 3b 20 09 20 28 74 68 69 73 73 65 ))).;; . (thisse
2880: 72 76 72 73 20 20 28 67 6c 6f 62 20 28 63 6f 6e rvrs (glob (con
2890: 63 20 73 72 76 64 69 72 22 2f 22 74 68 69 73 68 c srvdir"/"thish
28a0: 6f 73 74 69 70 22 3a 2a 22 29 29 29 0a 3b 3b 20 ostip":*"))).;;
28b0: 09 20 28 68 6f 6d 65 68 6f 73 74 69 6e 66 20 28 . (homehostinf (
28c0: 73 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 65 server:choose-se
28d0: 72 76 65 72 20 61 72 65 61 70 61 74 68 20 27 68 rver areapath 'h
28e0: 6f 6d 65 68 6f 73 74 29 29 0a 3b 3b 20 09 20 28 omehost)).;; . (
28f0: 68 61 76 65 68 6f 6d 65 20 20 20 20 28 63 61 72 havehome (car
2900: 20 68 6f 6d 65 68 6f 73 74 69 6e 66 29 29 0a 3b homehostinf)).;
2910: 3b 20 09 20 28 77 65 61 72 65 68 6f 6d 65 20 20 ; . (wearehome
2920: 20 28 63 64 72 20 68 6f 6d 65 68 6f 73 74 69 6e (cdr homehostin
2930: 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 64 65 62 f))).;; (deb
2940: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
2950: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2960: 74 2a 20 74 68 69 73 68 6f 73 74 69 70 22 2c 20 t* thishostip",
2970: 68 61 76 65 20 68 6f 6d 65 68 6f 73 74 3a 20 22 have homehost: "
2980: 68 61 76 65 68 6f 6d 65 22 2c 20 77 65 20 61 72 havehome", we ar
2990: 65 20 68 6f 6d 65 68 6f 73 74 3a 20 22 77 65 61 e homehost: "wea
29a0: 72 65 68 6f 6d 65 0a 3b 3b 20 09 09 20 20 20 20 rehome.;; ..
29b0: 20 20 22 2c 20 6e 75 6d 73 65 72 76 65 72 73 3a ", numservers:
29c0: 20 22 28 6c 65 6e 67 74 68 20 74 68 69 73 73 65 "(length thisse
29d0: 72 76 72 73 29 29 0a 3b 3b 20 20 20 20 20 28 63 rvrs)).;; (c
29e0: 6f 6e 64 0a 3b 3b 20 20 20 20 20 20 28 28 6e 6f ond.;; ((no
29f0: 74 20 68 61 76 65 68 6f 6d 65 29 20 23 74 29 20 t havehome) #t)
2a00: 3b 3b 20 6e 6f 20 68 6f 6d 65 68 6f 73 74 20 79 ;; no homehost y
2a10: 65 74 2c 20 67 6f 20 66 6f 72 20 69 74 0a 3b 3b et, go for it.;;
2a20: 20 20 20 20 20 20 28 28 61 6e 64 20 68 61 76 65 ((and have
2a30: 68 6f 6d 65 20 77 65 61 72 65 68 6f 6d 65 20 28 home wearehome (
2a40: 3c 20 28 6c 65 6e 67 74 68 20 74 68 69 73 73 65 < (length thisse
2a50: 72 76 72 73 29 20 32 30 29 29 20 23 74 29 20 3b rvrs) 20)) #t) ;
2a60: 3b 20 77 65 20 61 72 65 20 68 6f 6d 65 20 61 6e ; we are home an
2a70: 64 20 6c 65 73 73 20 74 68 61 6e 20 32 30 20 73 d less than 20 s
2a80: 65 72 76 65 72 73 2c 20 6f 6b 20 74 6f 20 73 74 ervers, ok to st
2a90: 61 72 74 20 61 6e 6f 74 68 65 72 0a 3b 3b 20 20 art another.;;
2aa0: 20 20 20 20 28 28 61 6e 64 20 68 61 76 65 68 6f ((and haveho
2ab0: 6d 65 20 28 6e 6f 74 20 77 65 61 72 65 68 6f 6d me (not wearehom
2ac0: 65 29 29 20 23 66 29 20 20 20 20 20 3b 3b 20 77 e)) #f) ;; w
2ad0: 65 20 61 72 65 20 6e 6f 74 20 74 68 65 20 68 6f e are not the ho
2ae0: 6d 65 20 68 6f 73 74 0a 3b 3b 20 20 20 20 20 20 me host.;;
2af0: 28 28 61 6e 64 20 68 61 76 65 68 6f 6d 65 20 77 ((and havehome w
2b00: 65 61 72 65 68 6f 6d 65 20 28 3e 3d 20 28 6c 65 earehome (>= (le
2b10: 6e 67 74 68 20 74 68 69 73 73 65 72 76 72 73 29 ngth thisservrs)
2b20: 20 32 30 29 29 20 23 66 29 20 3b 3b 20 68 61 76 20)) #f) ;; hav
2b30: 65 20 65 6e 6f 75 67 68 20 72 75 6e 6e 69 6e 67 e enough running
2b40: 0a 3b 3b 20 20 20 20 20 20 28 65 6c 73 65 0a 3b .;; (else.;
2b50: 3b 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ; (debug:p
2b60: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2b70: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
2b80: 4e 47 3a 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 NG: Unrecognised
2b90: 20 73 63 65 6e 61 72 69 6f 2c 20 73 65 72 76 72 scenario, servr
2ba0: 73 3d 22 73 65 72 76 72 73 22 2c 20 74 68 69 73 s="servrs", this
2bb0: 68 6f 73 74 69 70 3d 22 74 68 69 73 68 6f 73 74 hostip="thishost
2bc0: 69 70 22 2c 20 74 68 69 73 73 65 72 76 72 73 3d ip", thisservrs=
2bd0: 22 74 68 69 73 73 65 72 76 72 73 29 0a 3b 3b 20 "thisservrs).;;
2be0: 20 20 20 20 20 20 23 74 29 29 29 29 0a 09 20 0a #t)))).. .
2bf0: 0a 28 64 65 66 69 6e 65 20 73 65 72 76 65 72 2d .(define server-
2c00: 6c 61 73 74 2d 73 74 61 72 74 20 30 29 0a 0a 0a last-start 0)...
2c10: 3b 3b 20 6f 6c 64 65 73 74 20 73 65 72 76 65 72 ;; oldest server
2c20: 20 61 6c 69 76 65 20 64 65 74 65 72 6d 69 6e 65 alive determine
2c30: 73 20 68 6f 73 74 20 74 68 65 6e 20 63 68 6f 6f s host then choo
2c40: 73 65 20 72 61 6e 64 6f 6d 20 6f 66 20 79 6f 75 se random of you
2c50: 6e 67 65 73 74 0a 3b 3b 20 66 69 76 65 20 73 65 ngest.;; five se
2c60: 72 76 65 72 73 20 6f 6e 20 74 68 61 74 20 68 6f rvers on that ho
2c70: 73 74 0a 3b 3b 0a 3b 3b 20 6d 6f 64 65 3a 0a 3b st.;;.;; mode:.;
2c80: 3b 20 20 20 62 65 73 74 20 2d 20 67 65 74 20 62 ; best - get b
2c90: 65 73 74 20 73 65 72 76 65 72 20 28 72 61 6e 64 est server (rand
2ca0: 6f 6d 20 6f 66 20 6e 65 77 65 73 74 20 66 69 76 om of newest fiv
2cb0: 65 29 0a 3b 3b 20 20 20 68 6f 6d 65 20 2d 20 67 e).;; home - g
2cc0: 65 74 20 68 6f 6d 65 20 68 6f 73 74 20 62 61 73 et home host bas
2cd0: 65 64 20 6f 6e 20 6f 6c 64 65 73 74 20 73 65 72 ed on oldest ser
2ce0: 76 65 72 0a 3b 3b 20 20 20 69 6e 66 6f 20 2d 20 ver.;; info -
2cf0: 70 72 69 6e 74 20 69 6e 66 6f 0a 3b 3b 20 28 64 print info.;; (d
2d00: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 63 68 efine (server:ch
2d10: 6f 6f 73 65 2d 73 65 72 76 65 72 20 61 72 65 61 oose-server area
2d20: 70 61 74 68 20 23 21 6f 70 74 69 6f 6e 61 6c 20 path #!optional
2d30: 28 6d 6f 64 65 20 27 62 65 73 74 29 29 0a 3b 3b (mode 'best)).;;
2d40: 20 20 20 3b 3b 20 61 67 65 20 69 73 20 63 75 72 ;; age is cur
2d50: 72 65 6e 74 2d 73 74 61 72 74 74 69 6d 65 0a 3b rent-starttime.;
2d60: 3b 20 20 20 3b 3b 20 66 69 6e 64 20 6f 6c 64 65 ; ;; find olde
2d70: 73 74 20 61 6c 69 76 65 0a 3b 3b 20 20 20 3b 3b st alive.;; ;;
2d80: 20 20 20 31 2e 20 73 6f 72 74 20 62 79 20 61 67 1. sort by ag
2d90: 65 20 61 73 63 65 6e 64 69 6e 67 20 61 6e 64 20 e ascending and
2da0: 70 69 6e 67 20 75 6e 74 69 6c 20 67 6f 6f 64 0a ping until good.
2db0: 3b 3b 20 20 20 3b 3b 20 66 69 6e 64 20 61 6c 69 ;; ;; find ali
2dc0: 76 65 20 72 61 6e 64 20 66 72 6f 6d 20 79 6f 75 ve rand from you
2dd0: 6e 67 65 73 74 0a 3b 3b 20 20 20 3b 3b 20 20 20 ngest.;; ;;
2de0: 31 2e 20 73 6f 72 74 20 62 79 20 61 67 65 20 64 1. sort by age d
2df0: 65 73 63 65 6e 64 69 6e 67 0a 3b 3b 20 20 20 3b escending.;; ;
2e00: 3b 20 20 20 32 2e 20 74 61 6b 65 20 66 69 76 65 ; 2. take five
2e10: 0a 3b 3b 20 20 20 3b 3b 20 20 20 33 2e 20 63 68 .;; ;; 3. ch
2e20: 65 63 6b 20 61 6c 69 76 65 2c 20 64 69 73 63 61 eck alive, disca
2e30: 72 64 20 69 66 20 6e 6f 74 20 61 6e 64 20 72 65 rd if not and re
2e40: 70 65 61 74 0a 3b 3b 20 20 20 3b 3b 20 66 69 72 peat.;; ;; fir
2e50: 73 74 20 77 65 20 63 6c 65 61 6e 20 75 70 20 6f st we clean up o
2e60: 6c 64 20 73 65 72 76 65 72 20 66 69 6c 65 73 0a ld server files.
2e70: 3b 3b 20 20 20 28 61 73 73 65 72 74 20 28 65 71 ;; (assert (eq
2e80: 3f 20 28 72 6d 74 3a 74 72 61 6e 73 70 6f 72 74 ? (rmt:transport
2e90: 2d 6d 6f 64 65 29 20 27 68 74 74 70 29 20 22 46 -mode) 'http) "F
2ea0: 41 54 41 4c 3a 20 73 65 72 76 65 72 3a 72 75 6e ATAL: server:run
2eb0: 20 63 61 6c 6c 65 64 20 77 69 74 68 20 72 6d 74 called with rmt
2ec0: 3a 74 72 61 6e 73 70 6f 72 74 2d 6d 6f 64 65 3d :transport-mode=
2ed0: 22 28 72 6d 74 3a 74 72 61 6e 73 70 6f 72 74 2d "(rmt:transport-
2ee0: 6d 6f 64 65 29 29 0a 3b 3b 20 20 20 28 73 65 72 mode)).;; (ser
2ef0: 76 65 72 3a 63 6c 65 61 6e 2d 75 70 2d 6f 6c 64 ver:clean-up-old
2f00: 20 61 72 65 61 70 61 74 68 29 0a 3b 3b 20 20 20 areapath).;;
2f10: 28 6c 65 74 2a 20 28 28 73 69 6e 63 65 2d 6c 61 (let* ((since-la
2f20: 73 74 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 st (- (current-s
2f30: 65 63 6f 6e 64 73 29 20 73 65 72 76 65 72 2d 6c econds) server-l
2f40: 61 73 74 2d 73 74 61 72 74 29 29 0a 3b 3b 20 20 ast-start)).;;
2f50: 20 20 20 20 20 20 20 28 73 65 72 76 65 72 2d 73 (server-s
2f60: 74 61 72 74 2d 64 65 6c 61 79 20 31 30 29 29 20 tart-delay 10))
2f70: 20 20 20 20 0a 3b 3b 20 20 20 20 20 28 69 66 20 .;; (if
2f80: 28 20 3c 20 28 2d 20 28 63 75 72 72 65 6e 74 2d ( < (- (current-
2f90: 73 65 63 6f 6e 64 73 29 20 73 65 72 76 65 72 2d seconds) server-
2fa0: 6c 61 73 74 2d 73 74 61 72 74 29 20 31 30 20 29 last-start) 10 )
2fb0: 0a 3b 3b 20 20 20 20 20 20 20 28 62 65 67 69 6e .;; (begin
2fc0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 64 65 62 .;; (deb
2fd0: 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 ug:print 2 *defa
2fe0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 ult-log-port* "s
2ff0: 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 erver:choose-ser
3000: 76 65 72 3a 20 73 65 63 6f 6e 64 73 20 73 69 6e ver: seconds sin
3010: 63 65 20 6c 61 73 74 20 73 65 72 76 65 72 20 73 ce last server s
3020: 74 61 72 74 3a 20 22 20 28 2d 20 28 63 75 72 72 tart: " (- (curr
3030: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 65 72 ent-seconds) ser
3040: 76 65 72 2d 6c 61 73 74 2d 73 74 61 72 74 29 29 ver-last-start))
3050: 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 64 65 62 .;; (deb
3060: 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 ug:print 2 *defa
3070: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 ult-log-port* "s
3080: 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 erver:choose-ser
3090: 76 65 72 3a 20 6c 61 73 74 20 73 65 72 76 65 72 ver: last server
30a0: 20 73 74 61 72 74 20 6c 65 73 73 20 74 68 61 6e start less than
30b0: 20 22 20 73 65 72 76 65 72 2d 73 74 61 72 74 2d " server-start-
30c0: 64 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 73 20 delay " seconds
30d0: 61 67 6f 2e 20 53 6c 65 65 70 69 6e 67 20 22 20 ago. Sleeping "
30e0: 73 65 72 76 65 72 2d 73 74 61 72 74 2d 64 65 6c server-start-del
30f0: 61 79 20 22 20 73 65 63 6f 6e 64 73 22 29 0a 3b ay " seconds").;
3100: 3b 20 20 20 20 20 20 20 20 20 28 74 68 72 65 61 ; (threa
3110: 64 2d 73 6c 65 65 70 21 20 73 65 72 76 65 72 2d d-sleep! server-
3120: 73 74 61 72 74 2d 64 65 6c 61 79 29 0a 3b 3b 20 start-delay).;;
3130: 20 20 20 20 20 20 29 0a 3b 3b 20 20 20 20 20 20 ).;;
3140: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
3150: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3160: 74 2a 20 22 73 65 72 76 65 72 3a 63 68 6f 6f 73 t* "server:choos
3170: 65 2d 73 65 72 76 65 72 3a 20 73 65 63 6f 6e 64 e-server: second
3180: 73 20 73 69 6e 63 65 20 6c 61 73 74 20 73 65 72 s since last ser
3190: 76 65 72 20 73 74 61 72 74 3a 20 22 20 28 2d 20 ver start: " (-
31a0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
31b0: 29 20 73 65 72 76 65 72 2d 6c 61 73 74 2d 73 74 ) server-last-st
31c0: 61 72 74 29 29 0a 3b 3b 20 20 20 20 20 29 0a 3b art)).;; ).;
31d0: 3b 20 20 20 29 0a 3b 3b 20 20 20 28 6c 65 74 2a ; ).;; (let*
31e0: 20 28 28 73 65 72 76 65 72 73 64 61 74 20 20 28 ((serversdat (
31f0: 73 65 72 76 65 72 3a 67 65 74 2d 73 65 72 76 65 server:get-serve
3200: 72 73 2d 69 6e 66 6f 20 61 72 65 61 70 61 74 68 rs-info areapath
3210: 29 29 0a 3b 3b 20 09 20 28 73 65 72 76 6b 65 79 )).;; . (servkey
3220: 73 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 s (hash-table
3230: 2d 6b 65 79 73 20 73 65 72 76 65 72 73 64 61 74 -keys serversdat
3240: 29 29 0a 3b 3b 20 09 20 28 62 79 2d 74 69 6d 65 )).;; . (by-time
3250: 2d 61 73 63 20 28 69 66 20 28 6e 6f 74 20 28 6e -asc (if (not (n
3260: 75 6c 6c 3f 20 73 65 72 76 6b 65 79 73 29 29 20 ull? servkeys))
3270: 3b 3b 20 4e 4f 54 45 3a 20 4f 6c 64 65 73 74 20 ;; NOTE: Oldest
3280: 69 73 20 6c 61 73 74 0a 3b 3b 20 09 09 09 20 20 is last.;; ...
3290: 28 73 6f 72 74 20 73 65 72 76 6b 65 79 73 20 3b (sort servkeys ;
32a0: 3b 20 6c 69 73 74 20 6f 66 20 22 68 6f 73 74 3a ; list of "host:
32b0: 70 6f 72 74 22 0a 3b 3b 20 09 09 09 09 28 6c 61 port".;; ....(la
32c0: 6d 62 64 61 20 28 61 20 62 29 0a 3b 3b 20 09 09 mbda (a b).;; ..
32d0: 09 09 20 20 28 3e 3d 20 28 6c 69 73 74 2d 72 65 .. (>= (list-re
32e0: 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 f (hash-table-re
32f0: 66 20 73 65 72 76 65 72 73 64 61 74 20 61 29 20 f serversdat a)
3300: 32 29 0a 3b 3b 20 09 09 09 09 20 20 20 20 20 20 2).;; ....
3310: 28 6c 69 73 74 2d 72 65 66 20 28 68 61 73 68 2d (list-ref (hash-
3320: 74 61 62 6c 65 2d 72 65 66 20 73 65 72 76 65 72 table-ref server
3330: 73 64 61 74 20 62 29 20 32 29 29 29 29 0a 3b 3b sdat b) 2)))).;;
3340: 20 09 09 09 20 20 27 28 29 29 29 29 0a 3b 3b 20 ... '()))).;;
3350: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3360: 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 2 *default-log-
3370: 70 6f 72 74 2a 20 22 73 65 72 76 65 72 3a 63 68 port* "server:ch
3380: 6f 6f 73 65 2d 73 65 72 76 65 72 3a 20 73 65 72 oose-server: ser
3390: 76 65 72 73 64 61 74 3a 20 22 20 73 65 72 76 65 versdat: " serve
33a0: 72 73 64 61 74 29 0a 3b 3b 20 20 20 20 20 28 64 rsdat).;; (d
33b0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 ebug:print 2 *de
33c0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
33d0: 22 73 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 "server:choose-s
33e0: 65 72 76 65 72 3a 20 73 65 72 76 6b 65 79 73 3a erver: servkeys:
33f0: 20 22 20 73 65 72 76 6b 65 79 73 29 0a 3b 3b 20 " servkeys).;;
3400: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
3410: 6c 6c 3f 20 62 79 2d 74 69 6d 65 2d 61 73 63 29 ll? by-time-asc)
3420: 29 0a 3b 3b 20 09 28 6c 65 74 2a 20 28 28 6f 6c ).;; .(let* ((ol
3430: 64 65 73 74 20 20 20 20 20 28 6c 61 73 74 20 62 dest (last b
3440: 79 2d 74 69 6d 65 2d 61 73 63 29 29 0a 3b 3b 20 y-time-asc)).;;
3450: 09 20 20 20 20 20 20 20 28 6f 6c 64 65 73 74 2d . (oldest-
3460: 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d dat (hash-table-
3470: 72 65 66 20 73 65 72 76 65 72 73 64 61 74 20 6f ref serversdat o
3480: 6c 64 65 73 74 29 29 0a 3b 3b 20 09 20 20 20 20 ldest)).;; .
3490: 20 20 20 28 68 6f 73 74 20 20 20 20 20 20 20 28 (host (
34a0: 6c 69 73 74 2d 72 65 66 20 6f 6c 64 65 73 74 2d list-ref oldest-
34b0: 64 61 74 20 30 29 29 0a 3b 3b 20 09 20 20 20 20 dat 0)).;; .
34c0: 20 20 20 28 61 6c 6c 2d 76 61 6c 69 64 20 20 28 (all-valid (
34d0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
34e0: 78 29 0a 3b 3b 20 09 09 09 09 20 20 20 20 20 28 x).;; .... (
34f0: 65 71 75 61 6c 3f 20 68 6f 73 74 20 28 6c 69 73 equal? host (lis
3500: 74 2d 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c t-ref (hash-tabl
3510: 65 2d 72 65 66 20 73 65 72 76 65 72 73 64 61 74 e-ref serversdat
3520: 20 78 29 20 30 29 29 29 0a 3b 3b 20 09 09 09 09 x) 0))).;; ....
3530: 20 20 20 62 79 2d 74 69 6d 65 2d 61 73 63 29 29 by-time-asc))
3540: 0a 3b 3b 20 09 20 20 20 20 20 20 20 28 62 65 73 .;; . (bes
3550: 74 2d 74 65 6e 20 20 28 6c 61 6d 62 64 61 20 28 t-ten (lambda (
3560: 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 28 69 66 ).;; ... (if
3570: 20 28 3e 20 28 6c 65 6e 67 74 68 20 61 6c 6c 2d (> (length all-
3580: 76 61 6c 69 64 29 20 31 31 29 0a 3b 3b 20 09 09 valid) 11).;; ..
3590: 09 09 20 28 74 61 6b 65 20 28 64 72 6f 70 2d 72 .. (take (drop-r
35a0: 69 67 68 74 20 61 6c 6c 2d 76 61 6c 69 64 20 31 ight all-valid 1
35b0: 29 20 31 30 29 20 3b 3b 20 72 65 6d 6f 76 65 20 ) 10) ;; remove
35c0: 74 68 65 20 6f 6c 64 65 73 74 20 66 72 6f 6d 20 the oldest from
35d0: 63 6f 6e 73 69 64 65 72 61 74 69 6f 6e 20 73 6f consideration so
35e0: 20 69 74 20 63 61 6e 20 61 67 65 20 6f 75 74 0a it can age out.
35f0: 3b 3b 20 09 09 09 09 20 28 69 66 20 28 3e 20 28 ;; .... (if (> (
3600: 6c 65 6e 67 74 68 20 61 6c 6c 2d 76 61 6c 69 64 length all-valid
3610: 29 20 38 29 0a 3b 3b 20 09 09 09 09 20 20 20 20 ) 8).;; ....
3620: 20 28 64 72 6f 70 2d 72 69 67 68 74 20 61 6c 6c (drop-right all
3630: 2d 76 61 6c 69 64 20 31 29 0a 3b 3b 20 09 09 09 -valid 1).;; ...
3640: 09 20 20 20 20 20 61 6c 6c 2d 76 61 6c 69 64 29 . all-valid)
3650: 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 20 28 ))).;; . (
3660: 6e 61 6d 65 73 2d 3e 64 61 74 73 20 28 6c 61 6d names->dats (lam
3670: 62 64 61 20 28 6e 61 6d 65 73 29 0a 3b 3b 20 09 bda (names).;; .
3680: 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 .. (map (la
3690: 6d 62 64 61 20 28 78 29 0a 3b 3b 20 09 09 09 09 mbda (x).;; ....
36a0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
36b0: 2d 72 65 66 20 73 65 72 76 65 72 73 64 61 74 20 -ref serversdat
36c0: 78 29 29 0a 3b 3b 20 09 09 09 09 20 20 20 6e 61 x)).;; .... na
36d0: 6d 65 73 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 mes))).;; .
36e0: 20 20 28 61 6d 2d 68 6f 6d 65 3f 20 20 20 20 28 (am-home? (
36f0: 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 20 09 09 09 lambda ().;; ...
3700: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 63 75 (let* ((cu
3710: 72 72 68 6f 73 74 20 28 67 65 74 2d 68 6f 73 74 rrhost (get-host
3720: 2d 6e 61 6d 65 29 29 0a 3b 3b 20 09 09 09 09 20 -name)).;; ....
3730: 20 20 20 20 28 62 65 73 74 61 64 72 73 20 28 73 (bestadrs (s
3740: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 erver:get-best-g
3750: 75 65 73 73 2d 61 64 64 72 65 73 73 20 63 75 72 uess-address cur
3760: 72 68 6f 73 74 29 29 29 0a 3b 3b 20 09 09 09 09 rhost))).;; ....
3770: 28 6f 72 20 28 65 71 75 61 6c 3f 20 68 6f 73 74 (or (equal? host
3780: 20 63 75 72 72 68 6f 73 74 29 0a 3b 3b 20 09 09 currhost).;; ..
3790: 09 09 20 20 20 20 28 65 71 75 61 6c 3f 20 68 6f .. (equal? ho
37a0: 73 74 20 62 65 73 74 61 64 72 73 29 29 29 29 29 st bestadrs)))))
37b0: 29 0a 3b 3b 20 09 20 20 28 63 61 73 65 20 6d 6f ).;; . (case mo
37c0: 64 65 0a 3b 3b 20 09 20 20 20 20 28 28 69 6e 66 de.;; . ((inf
37d0: 6f 29 0a 3b 3b 20 09 20 20 20 20 20 28 64 65 62 o).;; . (deb
37e0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
37f0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6f ult-log-port* "o
3800: 6c 64 65 73 74 3a 20 22 6f 6c 64 65 73 74 2d 64 ldest: "oldest-d
3810: 61 74 22 2c 20 73 65 6c 65 63 74 65 64 20 68 6f at", selected ho
3820: 73 74 3a 20 22 68 6f 73 74 22 2c 20 61 6c 6c 2d st: "host", all-
3830: 76 61 6c 69 64 3a 20 22 61 6c 6c 2d 76 61 6c 69 valid: "all-vali
3840: 64 29 0a 3b 3b 20 09 20 20 20 20 20 28 64 65 62 d).;; . (deb
3850: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
3860: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 79 ult-log-port* "y
3870: 6f 75 6e 67 65 73 74 3a 20 22 28 68 61 73 68 2d oungest: "(hash-
3880: 74 61 62 6c 65 2d 72 65 66 20 73 65 72 76 65 72 table-ref server
3890: 73 64 61 74 20 28 63 61 72 20 61 6c 6c 2d 76 61 sdat (car all-va
38a0: 6c 69 64 29 29 29 29 0a 3b 3b 20 09 20 20 20 20 lid)))).;; .
38b0: 28 28 68 6f 6d 65 29 20 20 20 20 20 68 6f 73 74 ((home) host
38c0: 29 0a 3b 3b 20 09 20 20 20 20 28 28 68 6f 6d 65 ).;; . ((home
38d0: 68 6f 73 74 29 20 28 63 6f 6e 73 20 68 6f 73 74 host) (cons host
38e0: 20 28 61 6d 2d 68 6f 6d 65 3f 29 29 29 20 3b 3b (am-home?))) ;;
38f0: 20 73 68 75 74 20 75 70 20 6f 6c 64 20 63 6f 64 shut up old cod
3900: 65 0a 3b 3b 20 09 20 20 20 20 28 28 68 6f 6d 65 e.;; . ((home
3910: 3f 29 20 20 20 20 28 61 6d 2d 68 6f 6d 65 3f 29 ?) (am-home?)
3920: 29 0a 3b 3b 20 09 20 20 20 20 28 28 62 65 73 74 ).;; . ((best
3930: 2d 74 65 6e 29 28 6e 61 6d 65 73 2d 3e 64 61 74 -ten)(names->dat
3940: 73 20 28 62 65 73 74 2d 74 65 6e 29 29 29 0a 3b s (best-ten))).;
3950: 3b 20 09 20 20 20 20 28 28 61 6c 6c 2d 76 61 6c ; . ((all-val
3960: 69 64 29 28 6e 61 6d 65 73 2d 3e 64 61 74 73 20 id)(names->dats
3970: 61 6c 6c 2d 76 61 6c 69 64 29 29 0a 3b 3b 20 09 all-valid)).;; .
3980: 20 20 20 20 28 28 62 65 73 74 29 20 20 20 20 20 ((best)
3990: 28 6c 65 74 2a 20 28 28 62 65 73 74 2d 74 65 6e (let* ((best-ten
39a0: 20 28 62 65 73 74 2d 74 65 6e 29 29 0a 3b 3b 20 (best-ten)).;;
39b0: 09 09 09 20 20 20 20 20 20 20 28 6c 65 6e 20 20 ... (len
39c0: 20 20 20 20 20 28 6c 65 6e 67 74 68 20 62 65 73 (length bes
39d0: 74 2d 74 65 6e 29 29 29 0a 3b 3b 20 09 09 09 20 t-ten))).;; ...
39e0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
39f0: 20 73 65 72 76 65 72 73 64 61 74 20 28 6c 69 73 serversdat (lis
3a00: 74 2d 72 65 66 20 62 65 73 74 2d 74 65 6e 20 28 t-ref best-ten (
3a10: 72 61 6e 64 6f 6d 20 6c 65 6e 29 29 29 29 29 0a random len))))).
3a20: 3b 3b 20 09 20 20 20 20 28 28 63 6f 75 6e 74 29 ;; . ((count)
3a30: 28 6c 65 6e 67 74 68 20 61 6c 6c 2d 76 61 6c 69 (length all-vali
3a40: 64 29 29 0a 3b 3b 20 09 20 20 20 20 28 65 6c 73 d)).;; . (els
3a50: 65 0a 3b 3b 20 09 20 20 20 20 20 28 64 65 62 75 e.;; . (debu
3a60: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3a70: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
3a80: 52 4f 52 3a 20 69 6e 76 61 6c 69 64 20 63 6f 6d ROR: invalid com
3a90: 6d 61 6e 64 20 22 6d 6f 64 65 29 0a 3b 3b 20 09 mand "mode).;; .
3aa0: 20 20 20 20 20 23 66 29 29 29 0a 3b 3b 20 09 28 #f))).;; .(
3ab0: 62 65 67 69 6e 0a 3b 3b 20 09 20 20 28 73 65 72 begin.;; . (ser
3ac0: 76 65 72 3a 72 75 6e 20 61 72 65 61 70 61 74 68 ver:run areapath
3ad0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 ).;; (
3ae0: 73 65 74 21 20 73 65 72 76 65 72 2d 6c 61 73 74 set! server-last
3af0: 2d 73 74 61 72 74 20 28 63 75 72 72 65 6e 74 2d -start (current-
3b00: 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 20 09 20 20 seconds)).;; .
3b10: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
3b20: 21 20 33 29 0a 3b 3b 20 09 20 20 28 63 61 73 65 ! 3).;; . (case
3b30: 20 6d 6f 64 65 0a 3b 3b 20 09 20 20 20 20 28 28 mode.;; . ((
3b40: 68 6f 6d 65 68 6f 73 74 29 20 28 63 6f 6e 73 20 homehost) (cons
3b50: 23 66 20 23 66 29 29 0a 3b 3b 20 09 20 20 20 20 #f #f)).;; .
3b60: 28 65 6c 73 65 09 23 66 29 29 29 29 29 29 0a 0a (else.#f))))))..
3b70: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
3b80: 67 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 get-servinfo-dir
3b90: 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 6c 65 areapath). (le
3ba0: 74 2a 20 28 28 73 70 61 74 68 20 28 63 6f 6e 63 t* ((spath (conc
3bb0: 20 61 72 65 61 70 61 74 68 22 2f 2e 73 65 72 76 areapath"/.serv
3bc0: 69 6e 66 6f 22 29 29 29 0a 20 20 20 20 28 69 66 info"))). (if
3bd0: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 (not (file-exis
3be0: 74 73 3f 20 73 70 61 74 68 29 29 0a 09 28 63 72 ts? spath))..(cr
3bf0: 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 73 eate-directory s
3c00: 70 61 74 68 20 23 74 29 29 0a 20 20 20 20 73 70 path #t)). sp
3c10: 61 74 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ath))..(define (
3c20: 73 65 72 76 65 72 3a 63 6c 65 61 6e 2d 75 70 2d server:clean-up-
3c30: 6f 6c 64 20 61 72 65 61 70 61 74 68 29 0a 20 20 old areapath).
3c40: 3b 3b 20 61 6e 79 20 73 65 72 76 65 72 20 66 69 ;; any server fi
3c50: 6c 65 20 74 68 61 74 20 68 61 73 20 6e 6f 74 20 le that has not
3c60: 62 65 65 6e 20 74 6f 75 63 68 65 64 20 69 6e 20 been touched in
3c70: 74 65 6e 20 6d 69 6e 75 74 65 73 20 69 73 20 65 ten minutes is e
3c80: 66 66 65 63 74 69 76 65 6c 79 20 64 65 61 64 0a ffectively dead.
3c90: 20 20 28 6c 65 74 2a 20 28 28 73 66 69 6c 65 73 (let* ((sfiles
3ca0: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 28 73 65 (glob (conc (se
3cb0: 72 76 65 72 3a 67 65 74 2d 73 65 72 76 69 6e 66 rver:get-servinf
3cc0: 6f 2d 64 69 72 20 61 72 65 61 70 61 74 68 29 22 o-dir areapath)"
3cd0: 2f 2a 22 29 29 29 29 0a 20 20 20 20 28 66 6f 72 /*")))). (for
3ce0: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
3cf0: 64 61 20 28 73 66 69 6c 65 29 0a 20 20 20 20 20 da (sfile).
3d00: 20 20 28 6c 65 74 2a 20 28 28 6d 6f 64 74 69 6d (let* ((modtim
3d10: 65 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 e (handle-except
3d20: 69 6f 6e 73 0a 09 09 09 20 20 20 65 78 6e 0a 09 ions.... exn..
3d30: 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 .. (begin....
3d40: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
3d50: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3d60: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c * "WARNING: fail
3d70: 65 64 20 74 6f 20 67 65 74 20 6d 6f 64 69 66 69 ed to get modifi
3d80: 63 61 74 69 6f 6e 20 66 69 6c 65 20 66 6f 72 20 cation file for
3d90: 22 73 66 69 6c 65 29 0a 09 09 09 20 20 20 28 63 "sfile).... (c
3da0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
3db0: 0a 09 09 09 20 28 66 69 6c 65 2d 6d 6f 64 69 66 .... (file-modif
3dc0: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 66 69 ication-time sfi
3dd0: 6c 65 29 29 29 29 0a 09 20 28 69 66 20 28 61 6e le)))).. (if (an
3de0: 64 20 28 6e 75 6d 62 65 72 3f 20 6d 6f 64 74 69 d (number? modti
3df0: 6d 65 29 0a 09 09 20 20 28 3e 20 28 2d 20 28 63 me)... (> (- (c
3e00: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
3e10: 6d 6f 64 74 69 6d 65 29 0a 09 09 20 20 20 20 20 modtime)...
3e20: 36 30 30 29 29 0a 09 20 20 20 20 20 28 62 65 67 600)).. (beg
3e30: 69 6e 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 in.. (debu
3e40: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3e50: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
3e60: 52 4e 49 4e 47 3a 20 66 6f 75 6e 64 20 6f 6c 64 RNING: found old
3e70: 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 69 6c server info fil
3e80: 65 20 22 73 66 69 6c 65 22 2c 20 72 65 6d 6f 76 e "sfile", remov
3e90: 69 6e 67 20 69 74 2e 22 29 0a 09 20 20 20 20 20 ing it.")..
3ea0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
3eb0: 69 6f 6e 73 0a 09 09 20 20 20 65 78 6e 0a 09 09 ions... exn...
3ec0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
3ed0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3ee0: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 t* "WARNING: fai
3ef0: 6c 65 64 20 74 6f 20 64 65 6c 65 74 65 20 6f 6c led to delete ol
3f00: 64 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 69 d server info fi
3f10: 6c 65 20 22 73 66 69 6c 65 29 0a 09 09 20 28 64 le "sfile)... (d
3f20: 65 6c 65 74 65 2d 66 69 6c 65 20 73 66 69 6c 65 elete-file sfile
3f30: 29 29 29 29 29 29 0a 20 20 20 20 20 73 66 69 6c )))))). sfil
3f40: 65 73 29 29 29 0a 0a 3b 3b 20 74 69 6d 65 6f 75 es)))..;; timeou
3f50: 74 20 69 73 20 68 6d 73 20 73 74 72 69 6e 67 3a t is hms string:
3f60: 20 31 68 20 35 6d 20 33 73 2c 20 64 65 66 61 75 1h 5m 3s, defau
3f70: 6c 74 20 69 73 20 31 20 6d 69 6e 75 74 65 0a 3b lt is 1 minute.;
3f80: 3b 20 54 68 69 73 20 69 73 20 63 75 72 72 65 6e ; This is curren
3f90: 74 6c 79 20 62 72 6f 6b 65 6e 2e 20 4a 75 73 74 tly broken. Just
3fa0: 20 75 73 65 20 74 68 65 20 6e 75 6d 62 65 72 20 use the number
3fb0: 6f 66 20 68 6f 75 72 73 20 77 69 74 68 20 6e 6f of hours with no
3fc0: 20 75 6e 69 74 2e 0a 3b 3b 20 44 65 66 61 75 6c unit..;; Defaul
3fd0: 74 20 69 73 20 36 30 30 20 73 65 63 6f 6e 64 73 t is 600 seconds
3fe0: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 ..;;.(define (se
3ff0: 72 76 65 72 3a 65 78 70 69 72 61 74 69 6f 6e 2d rver:expiration-
4000: 74 69 6d 65 6f 75 74 29 0a 20 20 28 6c 65 74 2a timeout). (let*
4010: 20 28 28 74 6d 6f 20 28 63 6f 6e 66 69 67 66 3a ((tmo (configf:
4020: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
4030: 74 2a 20 22 73 65 72 76 65 72 22 20 22 74 69 6d t* "server" "tim
4040: 65 6f 75 74 22 29 29 29 0a 20 20 20 20 28 69 66 eout"))). (if
4050: 20 28 73 74 72 69 6e 67 3f 20 74 6d 6f 29 0a 09 (string? tmo)..
4060: 28 6c 65 74 2a 20 28 28 6e 75 6d 20 28 73 74 72 (let* ((num (str
4070: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 74 6d 6f 29 ing->number tmo)
4080: 29 29 0a 09 20 20 28 69 66 20 6e 75 6d 0a 09 20 )).. (if num..
4090: 20 20 20 20 20 28 2a 20 33 36 30 30 20 6e 75 6d (* 3600 num
40a0: 29 0a 09 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e ).. (common
40b0: 3a 68 6d 73 2d 73 74 72 69 6e 67 2d 3e 73 65 63 :hms-string->sec
40c0: 6f 6e 64 73 20 74 6d 6f 29 29 29 0a 09 36 30 30 onds tmo)))..600
40d0: 20 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 ;; this is the
40e0: 64 65 66 61 75 6c 74 0a 09 29 29 29 0a 0a 28 64 default..)))..(d
40f0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 efine (server:ge
4100: 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 t-best-guess-add
4110: 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a 20 ress hostname).
4120: 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 (let ((res #f))
4130: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
4140: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 64 (lambda (ad
4150: 72 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e r). (if (n
4160: 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 74 6f ot (eq? (u8vecto
4170: 72 2d 72 65 66 20 61 64 72 20 30 29 20 31 32 37 r-ref adr 0) 127
4180: 29 29 0a 09 20 20 20 28 73 65 74 21 20 72 65 73 )).. (set! res
4190: 20 61 64 72 29 29 29 0a 20 20 20 20 20 3b 3b 20 adr))). ;;
41a0: 4e 4f 54 45 3a 20 54 68 69 73 20 63 61 6e 20 66 NOTE: This can f
41b0: 61 69 6c 20 77 68 65 6e 20 74 68 65 72 65 20 69 ail when there i
41c0: 73 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 6f 66 20 s no mention of
41d0: 74 68 65 20 68 6f 73 74 20 69 6e 20 2f 65 74 63 the host in /etc
41e0: 2f 68 6f 73 74 73 2e 20 46 49 58 4d 45 0a 20 20 /hosts. FIXME.
41f0: 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 (vector->list
4200: 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 (hostinfo-addre
4210: 73 73 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e sses (hostname->
4220: 68 6f 73 74 69 6e 66 6f 20 68 6f 73 74 6e 61 6d hostinfo hostnam
4230: 65 29 29 29 29 0a 20 20 20 20 28 73 74 72 69 6e e)))). (strin
4240: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 g-intersperse .
4250: 20 20 20 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d (map number-
4260: 3e 73 74 72 69 6e 67 0a 09 20 20 28 75 38 76 65 >string.. (u8ve
4270: 63 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 20 20 28 ctor->list.. (
4280: 69 66 20 72 65 73 20 72 65 73 20 28 68 6f 73 74 if res res (host
4290: 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d name->ip hostnam
42a0: 65 29 29 29 29 20 22 2e 22 29 29 29 0a 0a 3b 3b e)))) ".")))..;;
42b0: 20 6d 6f 76 69 6e 67 20 74 68 69 73 20 68 65 72 moving this her
42c0: 65 20 61 73 20 69 74 20 6e 65 65 64 73 20 61 63 e as it needs ac
42d0: 63 65 73 73 20 74 6f 20 64 62 20 61 6e 64 20 63 cess to db and c
42e0: 61 6e 6e 6f 74 20 62 65 20 69 6e 20 63 6f 6d 6d annot be in comm
42f0: 6f 6e 2e 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 on..;;..(define
4300: 28 73 65 72 76 65 72 3a 67 65 74 2d 62 72 75 74 (server:get-brut
4310: 65 66 6f 72 63 65 2d 73 79 6e 63 65 72 20 64 62 eforce-syncer db
4320: 73 74 72 75 63 74 20 23 21 6b 65 79 20 28 66 6f struct #!key (fo
4330: 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 6f 75 6e 64 rk-to-background
4340: 20 23 66 29 20 28 70 65 72 73 69 73 74 2d 75 6e #f) (persist-un
4350: 74 69 6c 2d 73 79 6e 63 20 23 66 29 29 0a 20 20 til-sync #f)).
4360: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 22 57 41 (debug:print "WA
4370: 52 4e 49 4e 47 3a 20 62 72 75 74 65 66 6f 72 63 RNING: bruteforc
4380: 65 2d 73 79 6e 63 65 72 20 69 73 20 63 61 6c 6c e-syncer is call
4390: 65 64 20 62 75 74 20 68 61 73 20 62 65 65 6e 20 ed but has been
43a0: 64 69 73 61 62 6c 65 64 21 22 29 0a 20 20 28 6c disabled!"). (l
43b0: 61 6d 62 64 61 20 28 29 0a 20 20 20 20 28 64 65 ambda (). (de
43c0: 62 75 67 3a 70 72 69 6e 74 20 22 57 41 52 4e 49 bug:print "WARNI
43d0: 4e 47 3a 20 62 72 75 74 65 66 6f 72 63 65 2d 73 NG: bruteforce-s
43e0: 79 6e 63 65 72 20 69 73 20 63 61 6c 6c 65 64 20 yncer is called
43f0: 62 75 74 20 68 61 73 20 62 65 65 6e 20 64 69 73 but has been dis
4400: 61 62 6c 65 64 21 22 29 29 29 0a 0a 3b 3b 20 0a abled!")))..;; .
4410: 28 64 65 66 73 74 72 75 63 74 20 72 65 6d 6f 74 (defstruct remot
4420: 65 0a 0a 20 20 3b 3b 20 74 72 61 6e 73 70 6f 72 e.. ;; transpor
4430: 74 20 74 6f 20 62 65 20 75 73 65 64 0a 20 20 3b t to be used. ;
4440: 3b 20 68 74 74 70 20 20 20 20 20 20 20 20 20 20 ; http
4450: 20 20 20 20 2d 20 75 73 65 20 68 74 74 70 2d 74 - use http-t
4460: 72 61 6e 73 70 6f 72 74 0a 20 20 3b 3b 20 68 74 ransport. ;; ht
4470: 74 70 2d 72 65 61 64 2d 63 61 63 68 65 64 20 20 tp-read-cached
4480: 2d 20 75 73 65 20 68 74 74 70 2d 74 72 61 6e 73 - use http-trans
4490: 70 6f 72 74 20 66 6f 72 20 77 72 69 74 65 73 20 port for writes
44a0: 62 75 74 20 69 6e 2d 6d 65 6d 20 63 61 63 68 65 but in-mem cache
44b0: 64 20 66 6f 72 20 72 65 61 64 73 0a 20 20 28 72 d for reads. (r
44c0: 6d 6f 64 65 20 20 20 20 20 20 20 20 20 20 20 20 mode
44d0: 27 68 74 74 70 29 0a 20 20 28 68 68 2d 64 61 74 'http). (hh-dat
44e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
44f0: 20 28 28 72 65 73 20 28 6f 72 20 3b 3b 20 28 73 ((res (or ;; (s
4500: 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 erver:choose-ser
4510: 76 65 72 20 2a 74 6f 70 70 61 74 68 2a 20 27 68 ver *toppath* 'h
4520: 6f 6d 65 68 6f 73 74 29 0a 09 09 09 09 20 20 20 omehost).....
4530: 20 28 63 6f 6e 73 20 23 66 20 23 66 29 29 29 29 (cons #f #f))))
4540: 0a 09 09 20 20 20 20 20 20 20 28 61 73 73 65 72 ... (asser
4550: 74 20 28 70 61 69 72 3f 20 72 65 73 29 28 63 6f t (pair? res)(co
4560: 6e 63 20 22 46 41 54 41 4c 3a 20 68 68 2d 64 61 nc "FATAL: hh-da
4570: 74 20 73 68 6f 75 6c 64 20 62 65 20 61 20 70 61 t should be a pa
4580: 69 72 2c 20 67 6f 74 20 22 72 65 73 29 29 0a 09 ir, got "res))..
4590: 09 20 20 20 20 20 20 20 72 65 73 29 29 0a 20 20 . res)).
45a0: 28 73 65 72 76 65 72 2d 75 72 6c 20 20 20 20 20 (server-url
45b0: 20 20 20 23 66 29 20 3b 3b 20 28 73 65 72 76 65 #f) ;; (serve
45c0: 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 r:check-if-runni
45d0: 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 20 23 66 ng *toppath*) #f
45e0: 29 29 0a 20 20 28 73 65 72 76 65 72 2d 69 64 20 )). (server-id
45f0: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 73 #f). (s
4600: 65 72 76 65 72 2d 69 6e 66 6f 20 20 20 20 20 20 erver-info
4610: 20 23 66 29 20 3b 3b 20 28 69 66 20 2a 74 6f 70 #f) ;; (if *top
4620: 70 61 74 68 2a 20 28 73 65 72 76 65 72 3a 63 68 path* (server:ch
4630: 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a eck-if-running *
4640: 74 6f 70 70 61 74 68 2a 29 20 23 66 29 29 0a 20 toppath*) #f)).
4650: 20 28 6c 61 73 74 2d 73 65 72 76 65 72 2d 63 68 (last-server-ch
4660: 65 63 6b 20 30 29 20 20 3b 3b 20 6c 61 73 74 20 eck 0) ;; last
4670: 74 69 6d 65 20 77 65 20 63 68 65 63 6b 65 64 20 time we checked
4680: 74 6f 20 73 65 65 20 69 66 20 74 68 65 20 73 65 to see if the se
4690: 72 76 65 72 20 77 61 73 20 61 6c 69 76 65 0a 20 rver was alive.
46a0: 20 28 63 6f 6e 6e 65 63 74 2d 74 69 6d 65 20 20 (connect-time
46b0: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (current-sec
46c0: 6f 6e 64 73 29 29 20 3b 3b 20 77 68 65 6e 20 77 onds)) ;; when w
46d0: 65 20 66 69 72 73 74 20 63 6f 6e 6e 65 63 74 65 e first connecte
46e0: 64 0a 20 20 28 6c 61 73 74 2d 61 63 63 65 73 73 d. (last-access
46f0: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
4700: 73 65 63 6f 6e 64 73 29 29 20 3b 3b 20 6c 61 73 seconds)) ;; las
4710: 74 20 74 69 6d 65 20 77 65 20 74 61 6c 6b 65 64 t time we talked
4720: 20 74 6f 20 73 65 72 76 65 72 0a 20 20 3b 3b 20 to server. ;;
4730: 28 63 6f 6e 6e 64 61 74 20 20 20 20 20 20 20 20 (conndat
4740: 20 20 20 23 66 29 20 3b 3b 20 69 66 61 63 65 20 #f) ;; iface
4750: 70 6f 72 74 20 61 70 69 2d 75 72 69 20 61 70 69 port api-uri api
4760: 2d 75 72 6c 20 61 70 69 2d 72 65 71 20 73 65 63 -url api-req sec
4770: 6f 6e 64 73 20 73 65 72 76 65 72 2d 69 64 0a 20 onds server-id.
4780: 20 28 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 (server-timeout
4790: 20 20 20 20 28 73 65 72 76 65 72 3a 65 78 70 69 (server:expi
47a0: 72 61 74 69 6f 6e 2d 74 69 6d 65 6f 75 74 29 29 ration-timeout))
47b0: 0a 20 20 28 66 6f 72 63 65 2d 73 65 72 76 65 72 . (force-server
47c0: 20 20 20 20 20 20 23 66 29 0a 20 20 28 72 6f 2d #f). (ro-
47d0: 6d 6f 64 65 20 20 20 20 20 20 20 20 20 20 20 23 mode #
47e0: 66 29 20 20 0a 20 20 28 72 6f 2d 6d 6f 64 65 2d f) . (ro-mode-
47f0: 63 68 65 63 6b 65 64 20 20 20 23 66 29 20 3b 3b checked #f) ;;
4800: 20 66 6c 61 67 20 74 68 61 74 20 69 6e 64 69 63 flag that indic
4810: 61 74 65 73 20 77 65 20 68 61 76 65 20 63 68 65 ates we have che
4820: 63 6b 65 64 20 66 6f 72 20 72 6f 2d 6d 6f 64 65 cked for ro-mode
4830: 0a 0a 20 20 3b 3b 20 63 6f 6e 6e 64 61 74 20 73 .. ;; conndat s
4840: 74 75 66 66 0a 20 20 28 69 66 61 63 65 20 20 20 tuff. (iface
4850: 20 20 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b #f) ;;
4860: 20 54 4f 44 4f 3a 20 43 6f 6e 73 6f 6c 69 64 61 TODO: Consolida
4870: 74 65 20 74 68 69 73 20 64 61 74 61 20 77 69 74 te this data wit
4880: 68 20 73 65 72 76 65 72 2d 75 72 6c 20 61 6e 64 h server-url and
4890: 20 73 65 72 76 65 72 2d 69 6e 66 6f 20 61 62 6f server-info abo
48a0: 76 65 0a 20 20 28 70 6f 72 74 20 20 20 20 20 20 ve. (port
48b0: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 61 #f). (a
48c0: 70 69 2d 75 72 6c 20 20 20 20 20 20 20 20 20 20 pi-url
48d0: 20 23 66 29 0a 20 20 28 61 70 69 2d 75 72 69 20 #f). (api-uri
48e0: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 #f).
48f0: 28 61 70 69 2d 72 65 71 20 20 20 20 20 20 20 20 (api-req
4900: 20 20 20 23 66 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d #f))..;;=====
4910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4950: 3d 0a 3b 3b 20 52 6f 74 61 74 65 20 6c 6f 67 73 =.;; Rotate logs
4960: 2c 20 6c 6f 67 69 63 3a 20 0a 3b 3b 20 20 20 20 , logic: .;;
4970: 20 20 20 20 20 20 20 20 20 20 20 20 20 69 66 20 if
4980: 3e 20 35 30 30 6b 20 61 6e 64 20 6f 6c 64 65 72 > 500k and older
4990: 20 74 68 61 6e 20 31 20 77 65 65 6b 3a 0a 3b 3b than 1 week:.;;
49a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
49b0: 20 20 20 20 20 72 65 6d 6f 76 65 20 70 72 65 76 remove prev
49c0: 69 6f 75 73 20 63 6f 6d 70 72 65 73 73 65 64 20 ious compressed
49d0: 6c 6f 67 20 61 6e 64 20 63 6f 6d 70 72 65 73 73 log and compress
49e0: 20 74 68 69 73 20 6c 6f 67 0a 3b 3b 20 57 41 52 this log.;; WAR
49f0: 4e 49 4e 47 3a 20 54 68 69 73 20 70 72 6f 63 20 NING: This proc
4a00: 6f 70 65 72 61 74 65 73 20 61 73 73 75 6d 69 6e operates assumin
4a10: 67 20 74 68 61 74 20 69 74 20 69 73 20 69 6e 20 g that it is in
4a20: 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 61 62 the directory ab
4a30: 6f 76 65 20 74 68 65 0a 3b 3b 20 20 20 20 20 20 ove the.;;
4a40: 20 20 20 20 6c 6f 67 73 20 64 69 72 65 63 74 6f logs directo
4a50: 72 79 20 79 6f 75 20 77 69 73 68 20 74 6f 20 6c ry you wish to l
4a60: 6f 67 2d 72 6f 74 61 74 65 2e 0a 3b 3b 0a 28 64 og-rotate..;;.(d
4a70: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 6f efine (common:ro
4a80: 74 61 74 65 2d 6c 6f 67 73 29 0a 20 20 28 6c 65 tate-logs). (le
4a90: 74 2a 20 28 28 61 6c 6c 2d 66 69 6c 65 73 20 28 t* ((all-files (
4aa0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
4ab0: 29 0a 09 20 28 73 74 61 74 73 20 20 20 20 20 28 ).. (stats (
4ac0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
4ad0: 29 0a 09 20 28 69 6e 63 2d 73 74 61 74 20 20 28 ).. (inc-stat (
4ae0: 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 20 lambda (key)...
4af0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
4b00: 2d 73 65 74 21 20 73 74 61 74 73 20 6b 65 79 20 -set! stats key
4b10: 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (+ (hash-table-r
4b20: 65 66 2f 64 65 66 61 75 6c 74 20 73 74 61 74 73 ef/default stats
4b30: 20 6b 65 79 20 30 29 20 31 29 29 29 29 0a 09 28 key 0) 1))))..(
4b40: 6d 61 78 2d 61 6c 6c 6f 77 65 64 20 28 73 74 72 max-allowed (str
4b50: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 ing->number (or
4b60: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
4b70: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
4b80: 75 70 22 20 22 6d 61 78 2d 6c 6f 67 66 69 6c 65 up" "max-logfile
4b90: 73 22 29 20 22 36 30 30 22 29 29 29 29 20 3b 3b s") "600")))) ;;
4ba0: 20 6e 61 6d 65 20 2d 3e 20 61 67 65 0a 20 20 20 name -> age.
4bb0: 20 28 69 66 20 28 6e 6f 74 20 28 64 69 72 65 63 (if (not (direc
4bc0: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 22 6c 6f tory-exists? "lo
4bd0: 67 73 22 29 29 28 63 72 65 61 74 65 2d 64 69 72 gs"))(create-dir
4be0: 65 63 74 6f 72 79 20 22 6c 6f 67 73 22 29 29 0a ectory "logs")).
4bf0: 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 (directory-f
4c00: 6f 6c 64 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 old . (lambd
4c10: 61 20 28 66 69 6c 65 20 72 65 6d 29 0a 20 20 20 a (file rem).
4c20: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
4c30: 70 74 69 6f 6e 73 0a 09 65 78 6e 0a 09 28 62 65 ptions..exn..(be
4c40: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
4c50: 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 int-info 2 *defa
4c60: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 75 ult-log-port* "u
4c70: 6e 61 62 6c 65 20 74 6f 20 72 6f 74 61 74 65 20 nable to rotate
4c80: 6c 6f 67 20 22 20 66 69 6c 65 20 22 2c 20 70 72 log " file ", pr
4c90: 6f 62 61 62 6c 79 20 68 61 6e 64 6c 65 64 20 62 obably handled b
4ca0: 79 20 61 6e 6f 74 68 65 72 20 70 72 6f 63 65 73 y another proces
4cb0: 73 2c 20 74 68 69 73 20 69 73 20 73 61 66 65 20 s, this is safe
4cc0: 74 6f 20 69 67 6e 6f 72 65 2e 20 65 78 6e 3d 22 to ignore. exn="
4cd0: 20 65 78 6e 29 0a 09 20 20 28 64 65 62 75 67 3a exn).. (debug:
4ce0: 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 print 2 *default
4cf0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 -log-port* " mes
4d00: 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 sage: " ((condit
4d10: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
4d20: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
4d30: 61 67 65 29 20 65 78 6e 29 29 0a 09 20 20 3b 3b age) exn)).. ;;
4d40: 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 (print-call-cha
4d50: 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f in (current-erro
4d60: 72 2d 70 6f 72 74 29 29 20 3b 3b 20 0a 09 20 20 r-port)) ;; ..
4d70: 29 0a 09 28 6c 65 74 2a 20 28 28 66 75 6c 6c 6e )..(let* ((fulln
4d80: 61 6d 65 20 20 28 63 6f 6e 63 20 22 6c 6f 67 73 ame (conc "logs
4d90: 2f 22 20 66 69 6c 65 29 29 0a 09 20 20 20 20 20 /" file))..
4da0: 20 20 28 6d 6f 64 2d 74 69 6d 65 20 20 28 66 69 (mod-time (fi
4db0: 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d le-modification-
4dc0: 74 69 6d 65 20 66 75 6c 6c 6e 61 6d 65 29 29 0a time fullname)).
4dd0: 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d 61 67 . (file-ag
4de0: 65 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 e (- (current-s
4df0: 65 63 6f 6e 64 73 29 20 6d 6f 64 2d 74 69 6d 65 econds) mod-time
4e00: 29 29 0a 09 20 20 20 20 20 20 20 28 66 69 6c 65 )).. (file
4e10: 2d 6f 6c 64 20 20 28 3e 20 66 69 6c 65 2d 61 67 -old (> file-ag
4e20: 65 20 28 2a 20 34 38 20 36 30 20 36 30 29 29 29 e (* 48 60 60)))
4e30: 0a 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d 62 .. (file-b
4e40: 69 67 20 20 28 3e 20 28 66 69 6c 65 2d 73 69 7a ig (> (file-siz
4e50: 65 20 66 75 6c 6c 6e 61 6d 65 29 20 32 30 30 30 e fullname) 2000
4e60: 30 30 29 29 29 0a 09 20 20 28 68 61 73 68 2d 74 00))).. (hash-t
4e70: 61 62 6c 65 2d 73 65 74 21 20 61 6c 6c 2d 66 69 able-set! all-fi
4e80: 6c 65 73 20 66 69 6c 65 20 6d 6f 64 2d 74 69 6d les file mod-tim
4e90: 65 29 0a 09 20 20 28 69 66 20 28 6f 72 20 28 61 e).. (if (or (a
4ea0: 6e 64 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 nd (string-match
4eb0: 20 22 5e 2e 2a 2e 6c 6f 67 22 20 66 69 6c 65 29 "^.*.log" file)
4ec0: 0a 09 09 20 20 20 20 20 20 20 66 69 6c 65 2d 6f ... file-o
4ed0: 6c 64 0a 09 09 20 20 20 20 20 20 20 66 69 6c 65 ld... file
4ee0: 2d 62 69 67 29 0a 09 09 20 20 28 61 6e 64 20 28 -big)... (and (
4ef0: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 73 string-match "^s
4f00: 65 72 76 65 72 2d 2e 2a 2e 6c 6f 67 22 20 66 69 erver-.*.log" fi
4f10: 6c 65 29 0a 09 09 20 20 20 20 20 20 20 66 69 6c le)... fil
4f20: 65 2d 6f 6c 64 29 29 0a 09 20 20 20 20 20 20 28 e-old)).. (
4f30: 6c 65 74 20 28 28 67 7a 66 69 6c 65 20 28 63 6f let ((gzfile (co
4f40: 6e 63 20 66 75 6c 6c 6e 61 6d 65 20 22 2e 67 7a nc fullname ".gz
4f50: 22 29 29 29 0a 09 09 28 69 66 20 28 63 6f 6d 6d ")))...(if (comm
4f60: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
4f70: 67 7a 66 69 6c 65 29 0a 09 09 20 20 20 20 28 62 gzfile)... (b
4f80: 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 egin... (de
4f90: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
4fa0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4fb0: 72 74 2a 20 22 72 65 6d 6f 76 69 6e 67 20 22 20 rt* "removing "
4fc0: 67 7a 66 69 6c 65 29 0a 09 09 20 20 20 20 20 20 gzfile)...
4fd0: 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 67 7a (delete-file* gz
4fe0: 66 69 6c 65 29 0a 09 09 20 20 20 20 20 20 28 68 file)... (h
4ff0: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
5000: 21 20 20 61 6c 6c 2d 66 69 6c 65 73 20 67 7a 66 ! all-files gzf
5010: 69 6c 65 29 20 3b 3b 20 6e 65 65 64 65 64 3f 0a ile) ;; needed?.
5020: 09 09 20 20 20 20 20 20 29 29 0a 09 09 28 64 65 .. ))...(de
5030: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
5040: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5050: 72 74 2a 20 22 63 6f 6d 70 72 65 73 73 69 6e 67 rt* "compressing
5060: 20 22 20 66 69 6c 65 29 0a 09 09 28 73 79 73 74 " file)...(syst
5070: 65 6d 20 28 63 6f 6e 63 20 22 67 7a 69 70 20 22 em (conc "gzip "
5080: 20 66 75 6c 6c 6e 61 6d 65 29 29 0a 09 09 28 69 fullname))...(i
5090: 6e 63 2d 73 74 61 74 20 22 67 7a 69 70 70 65 64 nc-stat "gzipped
50a0: 22 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 ")...(hash-table
50b0: 2d 73 65 74 21 20 61 6c 6c 2d 66 69 6c 65 73 20 -set! all-files
50c0: 28 63 6f 6e 63 20 66 69 6c 65 20 22 2e 67 7a 22 (conc file ".gz"
50d0: 29 20 66 69 6c 65 2d 61 67 65 29 20 20 3b 3b 20 ) file-age) ;;
50e0: 61 64 64 20 74 68 65 20 2e 67 7a 20 66 69 6c 65 add the .gz file
50f0: 20 61 6e 64 20 72 65 6d 6f 76 65 20 74 68 65 20 and remove the
5100: 62 61 73 65 20 66 69 6c 65 0a 09 09 28 68 61 73 base file...(has
5110: 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
5120: 61 6c 6c 2d 66 69 6c 65 73 20 66 69 6c 65 29 0a all-files file).
5130: 09 09 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ..).. (if (
5140: 61 6e 64 20 28 3e 20 66 69 6c 65 2d 61 67 65 20 and (> file-age
5150: 28 2a 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 (* (string->numb
5160: 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a er (or (configf:
5170: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
5180: 74 2a 20 22 73 65 74 75 70 22 20 22 6c 6f 67 2d t* "setup" "log-
5190: 65 78 70 69 72 65 2d 64 61 79 73 22 29 20 22 33 expire-days") "3
51a0: 30 22 29 29 20 32 34 20 33 36 30 30 29 29 0a 09 0")) 24 3600))..
51b0: 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d 65 78 . (file-ex
51c0: 69 73 74 73 3f 20 66 75 6c 6c 6e 61 6d 65 29 29 ists? fullname))
51d0: 20 3b 3b 20 6a 75 73 74 20 69 6e 20 63 61 73 65 ;; just in case
51e0: 20 69 74 20 77 61 73 20 67 7a 69 70 70 65 64 20 it was gzipped
51f0: 2d 20 77 69 6c 6c 20 67 65 74 20 69 74 20 6e 65 - will get it ne
5200: 78 74 20 74 69 6d 65 0a 09 09 20 20 28 68 61 6e xt time... (han
5210: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
5220: 09 20 20 20 65 78 6e 0a 09 09 20 20 20 23 66 0a . exn... #f.
5230: 09 09 20 20 20 28 69 66 20 28 64 69 72 65 63 74 .. (if (direct
5240: 6f 72 79 3f 20 66 75 6c 6c 6e 61 6d 65 29 0a 09 ory? fullname)..
5250: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
5260: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
5270: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
5280: 6c 6f 67 2d 70 6f 72 74 2a 20 66 75 6c 6c 6e 61 log-port* fullna
5290: 6d 65 20 22 20 69 6e 20 6c 6f 67 73 20 64 69 72 me " in logs dir
52a0: 65 63 74 6f 72 79 20 69 73 20 61 20 64 69 72 65 ectory is a dire
52b0: 63 74 6f 72 79 21 20 43 61 6e 6e 6f 74 20 72 6f ctory! Cannot ro
52c0: 74 61 74 65 20 69 74 2c 20 69 74 20 69 73 20 62 tate it, it is b
52d0: 65 73 74 20 74 6f 20 6e 6f 74 20 70 75 74 20 73 est to not put s
52e0: 75 62 64 69 72 65 63 74 6f 72 69 65 73 20 69 6e ubdirectories in
52f0: 20 74 68 65 20 6c 6f 67 73 20 64 69 72 2e 22 29 the logs dir.")
5300: 0a 09 09 09 20 28 69 6e 63 2d 73 74 61 74 20 22 .... (inc-stat "
5310: 64 69 72 65 63 74 6f 72 69 65 73 22 29 29 0a 09 directories"))..
5320: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
5330: 09 09 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a .. (delete-file*
5340: 20 66 75 6c 6c 6e 61 6d 65 29 0a 09 09 09 20 28 fullname).... (
5350: 69 6e 63 2d 73 74 61 74 20 22 64 65 6c 65 74 65 inc-stat "delete
5360: 64 22 29 29 29 0a 09 09 20 20 20 28 68 61 73 68 d")))... (hash
5370: 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 61 -table-delete! a
5380: 6c 6c 2d 66 69 6c 65 73 20 66 69 6c 65 29 29 29 ll-files file)))
5390: 29 29 29 29 0a 20 20 20 20 20 27 28 29 0a 20 20 )))). '().
53a0: 20 20 20 22 6c 6f 67 73 22 29 0a 20 20 20 20 28 "logs"). (
53b0: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
53c0: 61 6d 62 64 61 20 28 63 61 74 65 67 6f 72 79 29 ambda (category)
53d0: 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 71 . (let ((q
53e0: 75 61 6e 74 20 28 68 61 73 68 2d 74 61 62 6c 65 uant (hash-table
53f0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 74 61 -ref/default sta
5400: 74 73 20 63 61 74 65 67 6f 72 79 20 30 29 29 29 ts category 0)))
5410: 0a 09 20 28 69 66 20 28 3e 20 71 75 61 6e 74 20 .. (if (> quant
5420: 30 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 0).. (debug:
5430: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5440: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5450: 63 61 74 65 67 6f 72 79 20 22 20 6c 6f 67 20 66 category " log f
5460: 69 6c 65 73 3a 20 22 20 71 75 61 6e 74 29 29 29 iles: " quant)))
5470: 29 0a 20 20 20 20 20 60 28 22 64 65 6c 65 74 65 ). `("delete
5480: 64 22 20 22 67 7a 69 70 70 65 64 22 20 22 64 69 d" "gzipped" "di
5490: 72 65 63 74 6f 72 69 65 73 22 29 29 0a 20 20 20 rectories")).
54a0: 20 28 6c 65 74 20 28 28 6e 75 6d 2d 6c 6f 67 73 (let ((num-logs
54b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 69 7a (hash-table-siz
54c0: 65 20 61 6c 6c 2d 66 69 6c 65 73 29 29 29 0a 20 e all-files))).
54d0: 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 2d (if (> num-
54e0: 6c 6f 67 73 20 6d 61 78 2d 61 6c 6c 6f 77 65 64 logs max-allowed
54f0: 29 20 3b 3b 20 62 65 63 61 75 73 65 20 4e 46 53 ) ;; because NFS
5500: 20 3d 3e 20 64 6f 6e 27 74 20 6c 65 74 20 6e 75 => don't let nu
5510: 6d 62 65 72 20 6f 66 20 6c 6f 67 73 20 65 78 63 mber of logs exc
5520: 65 65 64 20 33 30 30 0a 09 20 20 28 6c 65 74 20 eed 300.. (let
5530: 28 28 66 69 6c 65 73 20 28 74 61 6b 65 20 28 73 ((files (take (s
5540: 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ort (hash-table-
5550: 6b 65 79 73 20 61 6c 6c 2d 66 69 6c 65 73 29 0a keys all-files).
5560: 09 09 09 09 20 20 20 28 6c 61 6d 62 64 61 20 28 .... (lambda (
5570: 61 20 62 29 0a 09 09 09 09 20 20 20 20 20 28 3c a b)..... (<
5580: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5590: 20 61 6c 6c 2d 66 69 6c 65 73 20 61 29 28 68 61 all-files a)(ha
55a0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 61 6c 6c sh-table-ref all
55b0: 2d 66 69 6c 65 73 20 62 29 29 29 29 0a 09 09 09 -files b))))....
55c0: 20 20 20 20 20 28 2d 20 6e 75 6d 2d 6c 6f 67 73 (- num-logs
55d0: 20 6d 61 78 2d 61 6c 6c 6f 77 65 64 29 29 29 29 max-allowed))))
55e0: 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a .. (for-each.
55f0: 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 66 . (lambda (f
5600: 69 6c 65 29 0a 09 20 20 20 20 20 20 20 28 6c 65 ile).. (le
5610: 74 2a 20 28 28 66 75 6c 6c 6e 61 6d 65 20 28 63 t* ((fullname (c
5620: 6f 6e 63 20 22 6c 6f 67 73 2f 22 20 66 69 6c 65 onc "logs/" file
5630: 29 29 29 0a 09 09 20 28 69 66 20 28 64 69 72 65 )))... (if (dire
5640: 63 74 6f 72 79 3f 20 66 75 6c 6c 6e 61 6d 65 29 ctory? fullname)
5650: 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
5660: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
5670: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 66 ault-log-port* f
5680: 75 6c 6c 6e 61 6d 65 20 22 20 69 6e 20 6c 6f 67 ullname " in log
5690: 73 20 64 69 72 65 63 74 6f 72 79 20 69 73 20 61 s directory is a
56a0: 20 64 69 72 65 63 74 6f 72 79 21 20 43 61 6e 6e directory! Cann
56b0: 6f 74 20 72 6f 74 61 74 65 20 69 74 2c 20 69 74 ot rotate it, it
56c0: 20 69 73 20 62 65 73 74 20 74 6f 20 6e 6f 74 20 is best to not
56d0: 70 75 74 20 73 75 62 64 69 72 65 63 74 6f 72 69 put subdirectori
56e0: 65 73 20 69 6e 20 74 68 65 20 6c 6f 67 73 20 64 es in the logs d
56f0: 69 72 2e 22 29 0a 09 09 20 20 20 20 20 28 68 61 ir.")... (ha
5700: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
5710: 09 09 20 20 20 20 20 20 65 78 6e 0a 09 09 20 20 .. exn...
5720: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5730: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
5740: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 69 t-log-port* "fai
5750: 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 led to remove "
5760: 66 75 6c 6c 6e 61 6d 65 20 22 2c 20 65 78 6e 3d fullname ", exn=
5770: 22 20 65 78 6e 29 0a 09 09 20 20 20 20 20 20 28 " exn)... (
5780: 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 75 6c delete-file* ful
5790: 6c 6e 61 6d 65 29 29 29 29 29 0a 09 20 20 20 20 lname)))))..
57a0: 20 66 69 6c 65 73 29 0a 09 20 20 20 20 28 64 65 files).. (de
57b0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
57c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
57d0: 72 74 2a 20 22 44 65 6c 65 74 65 64 20 22 20 28 rt* "Deleted " (
57e0: 6c 65 6e 67 74 68 20 66 69 6c 65 73 29 20 22 20 length files) "
57f0: 66 69 6c 65 73 20 66 72 6f 6d 20 6c 6f 67 73 2c files from logs,
5800: 20 6b 65 65 70 69 6e 67 20 22 20 6d 61 78 2d 61 keeping " max-a
5810: 6c 6c 6f 77 65 64 20 22 20 66 69 6c 65 73 2e 22 llowed " files."
5820: 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))))))..;;======
5830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5870: 0a 3b 3b 20 45 20 58 20 49 20 54 20 20 20 48 20 .;; E X I T H
5880: 41 20 4e 20 44 20 4c 20 49 20 4e 20 47 0a 3b 3b A N D L I N G.;;
5890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58d0: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
58e0: 28 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 (std-signal-hand
58f0: 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 20 3b 3b ler signum). ;;
5900: 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 (signal-mask! s
5910: 69 67 6e 75 6d 29 0a 20 20 28 73 65 74 21 20 2a ignum). (set! *
5920: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 time-to-exit* #t
5930: 29 20 0a 20 20 3b 3b 28 64 65 62 75 67 3a 70 72 ) . ;;(debug:pr
5940: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
5950: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5960: 67 6f 74 20 73 69 67 6e 61 6c 20 22 73 69 67 6e got signal "sign
5970: 75 6d 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 um). (debug:pri
5980: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
5990: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 ult-log-port* "R
59a0: 65 63 65 69 76 65 64 20 73 69 67 6e 61 6c 20 22 eceived signal "
59b0: 20 73 69 67 6e 75 6d 20 22 20 61 61 61 20 65 78 signum " aaa ex
59c0: 69 74 69 6e 67 20 70 72 6f 6d 70 74 6c 79 22 29 iting promptly")
59d0: 0a 20 20 3b 3b 20 28 73 74 64 2d 65 78 69 74 2d . ;; (std-exit-
59e0: 70 72 6f 63 65 64 75 72 65 29 20 3b 3b 20 73 68 procedure) ;; sh
59f0: 6f 75 6c 64 6e 27 74 20 6e 65 65 64 20 74 68 69 ouldn't need thi
5a00: 73 20 73 69 6e 63 65 20 77 65 20 61 72 65 20 65 s since we are e
5a10: 78 69 74 69 6e 67 20 61 6e 64 20 69 74 20 77 69 xiting and it wi
5a20: 6c 6c 20 62 65 20 63 61 6c 6c 65 64 20 61 6e 79 ll be called any
5a30: 77 61 79 0a 20 20 28 65 78 69 74 29 29 0a 0a 28 way. (exit))..(
5a40: 64 65 66 69 6e 65 20 28 73 70 65 63 69 61 6c 2d define (special-
5a50: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 signal-handler s
5a60: 69 67 6e 75 6d 29 0a 20 20 3b 3b 20 28 73 69 67 ignum). ;; (sig
5a70: 6e 61 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d nal-mask! signum
5a80: 29 0a 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d ). (set! *time-
5a90: 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 3b to-exit* #t). ;
5aa0: 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e ;(debug:print-in
5ab0: 66 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c fo 13 *default-l
5ac0: 6f 67 2d 70 6f 72 74 2a 20 22 67 6f 74 20 73 69 og-port* "got si
5ad0: 67 6e 61 6c 20 22 73 69 67 6e 75 6d 29 0a 20 20 gnal "signum).
5ae0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
5af0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
5b00: 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 69 76 65 g-port* "Receive
5b10: 64 20 73 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 d signal " signu
5b20: 6d 20 22 20 73 65 6e 64 69 6e 67 20 65 6d 61 69 m " sending emai
5b30: 6c 20 62 65 66 6f 72 20 65 78 69 74 69 6e 67 21 l befor exiting!
5b40: 21 22 29 0a 20 20 3b 3b 54 4f 44 4f 20 73 65 6e !"). ;;TODO sen
5b50: 64 20 65 6d 61 69 6c 20 74 6f 20 6e 6f 74 69 66 d email to notif
5b60: 79 20 61 64 6d 69 6e 20 63 6f 6e 74 61 63 74 20 y admin contact
5b70: 6c 69 73 74 65 64 20 69 6e 20 74 68 65 20 63 6f listed in the co
5b80: 6e 66 69 67 20 74 68 61 74 20 74 68 65 20 6c 69 nfig that the li
5b90: 73 6e 65 72 20 67 6f 74 20 6b 69 6c 6c 65 64 0a sner got killed.
5ba0: 20 20 3b 3b 20 28 73 74 64 2d 65 78 69 74 2d 70 ;; (std-exit-p
5bb0: 72 6f 63 65 64 75 72 65 29 20 3b 3b 20 73 68 6f rocedure) ;; sho
5bc0: 75 6c 64 6e 27 74 20 6e 65 65 64 20 74 68 69 73 uldn't need this
5bd0: 20 73 69 6e 63 65 20 77 65 20 61 72 65 20 65 78 since we are ex
5be0: 69 74 69 6e 67 20 61 6e 64 20 69 74 20 77 69 6c iting and it wil
5bf0: 6c 20 62 65 20 63 61 6c 6c 65 64 20 61 6e 79 77 l be called anyw
5c00: 61 79 0a 20 20 28 65 78 69 74 29 29 0a 0a 0a 28 ay. (exit))...(
5c10: 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c set-signal-handl
5c20: 65 72 21 20 73 69 67 6e 61 6c 2f 69 6e 74 20 20 er! signal/int
5c30: 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c std-signal-handl
5c40: 65 72 29 20 20 3b 3b 20 5e 43 0a 28 73 65 74 2d er) ;; ^C.(set-
5c50: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 signal-handler!
5c60: 73 69 67 6e 61 6c 2f 74 65 72 6d 20 73 74 64 2d signal/term std-
5c70: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 0a signal-handler).
5c80: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
5c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cc0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 63 61 6c 63 ========.;; calc
5cd0: 75 6c 61 74 65 20 61 20 64 65 6c 61 79 20 6e 75 ulate a delay nu
5ce0: 6d 62 65 72 20 62 61 73 65 64 20 6f 6e 20 61 20 mber based on a
5cf0: 64 72 6f 6f 70 20 63 75 72 76 65 0a 3b 3b 20 20 droop curve.;;
5d00: 20 20 69 6e 70 75 74 73 20 61 72 65 3a 0a 3b 3b inputs are:.;;
5d10: 20 20 20 20 20 20 2d 20 6c 6f 61 64 2d 69 6e 2c - load-in,
5d20: 20 6c 6f 61 64 20 61 73 20 66 72 6f 6d 20 75 70 load as from up
5d30: 74 69 6d 65 2c 20 4e 4f 54 20 6e 6f 72 6d 61 6c time, NOT normal
5d40: 69 7a 65 64 0a 3b 3b 20 20 20 20 20 20 2d 20 6e ized.;; - n
5d50: 75 6d 63 70 75 73 2c 20 6e 75 6d 62 65 72 20 6f umcpus, number o
5d60: 66 20 63 70 75 73 2c 20 69 64 65 61 6c 6c 79 20 f cpus, ideally
5d70: 75 73 65 20 74 68 65 20 72 65 61 6c 20 63 70 75 use the real cpu
5d80: 73 2c 20 6e 6f 74 20 74 68 72 65 61 64 73 0a 3b s, not threads.;
5d90: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
5da0: 6e 3a 67 65 74 2d 64 65 6c 61 79 20 6c 6f 61 64 n:get-delay load
5db0: 2d 69 6e 20 6e 75 6d 63 70 75 73 29 0a 20 20 28 -in numcpus). (
5dc0: 6c 65 74 2a 20 28 28 72 61 74 69 6f 20 28 2f 20 let* ((ratio (/
5dd0: 6c 6f 61 64 2d 69 6e 20 6e 75 6d 63 70 75 73 29 load-in numcpus)
5de0: 29 0a 20 20 20 20 20 20 20 20 20 28 6e 65 77 2d ). (new-
5df0: 6f 70 74 69 6f 6e 20 28 63 6f 6e 66 69 67 66 3a option (configf:
5e00: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
5e10: 74 2a 20 22 6c 6f 61 64 22 20 22 6e 65 77 2d 6c t* "load" "new-l
5e20: 6f 61 64 2d 6d 65 74 68 6f 64 22 29 29 0a 09 20 oad-method"))..
5e30: 28 70 61 72 61 6d 73 74 72 20 20 20 28 6f 72 20 (paramstr (or
5e40: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
5e50: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6c 6f 61 *configdat* "loa
5e60: 64 22 20 22 65 78 70 2d 70 61 72 61 6d 73 22 29 d" "exp-params")
5e70: 0a 09 09 09 20 22 31 35 20 31 32 20 31 32 38 31 .... "15 12 1281
5e80: 34 35 33 39 38 37 2e 39 35 34 33 20 30 2e 37 35 453987.9543 0.75
5e90: 22 29 29 20 3b 3b 20 35 20 34 20 31 30 20 31 22 ")) ;; 5 4 10 1"
5ea0: 29 29 0a 09 20 28 70 61 72 61 6d 6c 73 74 20 20 )).. (paramlst
5eb0: 20 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 (map string->nu
5ec0: 6d 62 65 72 20 28 73 74 72 69 6e 67 2d 73 70 6c mber (string-spl
5ed0: 69 74 20 70 61 72 61 6d 73 74 72 29 29 29 29 0a it paramstr)))).
5ee0: 20 20 20 20 28 69 66 20 6e 65 77 2d 6f 70 74 69 (if new-opti
5ef0: 6f 6e 0a 09 28 62 65 67 69 6e 0a 20 20 20 20 20 on..(begin.
5f00: 20 20 20 20 20 28 63 6f 6e 64 20 28 28 61 6e 64 (cond ((and
5f10: 20 28 3e 3d 20 72 61 74 69 6f 20 30 29 20 28 3c (>= ratio 0) (<
5f20: 20 72 61 74 69 6f 20 2e 35 29 29 0a 09 09 20 30 ratio .5))... 0
5f30: 29 0a 09 09 28 28 61 6e 64 20 28 3e 3d 20 72 61 )...((and (>= ra
5f40: 74 69 6f 20 30 2e 35 29 20 28 3c 3d 20 72 61 74 tio 0.5) (<= rat
5f50: 69 6f 20 2e 39 29 29 0a 09 09 20 28 2a 20 72 61 io .9))... (* ra
5f60: 74 69 6f 20 28 2f 20 35 20 2e 39 29 29 29 0a 09 tio (/ 5 .9)))..
5f70: 09 28 28 61 6e 64 20 28 3e 20 72 61 74 69 6f 20 .((and (> ratio
5f80: 2e 39 29 20 28 3c 3d 20 72 61 74 69 6f 20 31 2e .9) (<= ratio 1.
5f90: 31 29 29 0a 09 09 20 28 2b 20 35 20 28 2a 20 28 1))... (+ 5 (* (
5fa0: 2d 20 72 61 74 69 6f 20 2e 39 29 20 28 2f 20 35 - ratio .9) (/ 5
5fb0: 35 20 2e 32 29 29 29 29 20 0a 09 09 28 28 3e 20 5 .2)))) ...((>
5fc0: 72 61 74 69 6f 20 31 2e 31 29 0a 09 09 20 36 30 ratio 1.1)... 60
5fd0: 29 29 29 0a 09 28 6d 61 74 63 68 20 70 61 72 61 )))..(match para
5fe0: 6d 6c 73 74 0a 09 20 20 28 28 72 31 20 72 32 20 mlst.. ((r1 r2
5ff0: 73 31 20 73 32 29 0a 09 20 20 20 28 64 65 62 75 s1 s2).. (debu
6000: 67 3a 70 72 69 6e 74 20 33 20 2a 64 65 66 61 75 g:print 3 *defau
6010: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 73 lt-log-port* "Us
6020: 69 6e 67 20 70 61 72 61 6d 73 20 72 31 3d 22 20 ing params r1="
6030: 72 31 20 22 20 72 32 3d 22 20 72 32 20 22 20 73 r1 " r2=" r2 " s
6040: 31 3d 22 20 73 31 20 22 20 73 32 3d 22 20 73 32 1=" s1 " s2=" s2
6050: 29 0a 09 20 20 20 28 6d 69 6e 20 28 6d 61 78 20 ).. (min (max
6060: 28 2f 20 28 65 78 70 74 20 72 31 20 28 2a 20 72 (/ (expt r1 (* r
6070: 32 20 73 32 20 72 61 74 69 6f 29 29 20 73 31 29 2 s2 ratio)) s1)
6080: 20 30 29 20 33 30 29 29 0a 09 20 20 28 65 6c 73 0) 30)).. (els
6090: 65 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 e.. (debug:pri
60a0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
60b0: 67 2d 70 6f 72 74 2a 20 22 42 41 44 20 65 78 70 g-port* "BAD exp
60c0: 2d 70 61 72 61 6d 73 2c 20 73 68 6f 75 6c 64 20 -params, should
60d0: 62 65 20 5c 22 72 31 20 72 32 20 73 31 20 73 32 be \"r1 r2 s1 s2
60e0: 5c 22 20 62 75 74 20 67 6f 74 20 22 20 70 61 72 \" but got " par
60f0: 61 6d 73 74 72 29 0a 09 20 20 20 33 30 29 29 29 amstr).. 30)))
6100: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
6110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
6150: 44 4f 20 4e 4f 54 20 43 41 4c 4c 20 54 48 49 53 DO NOT CALL THIS
6160: 20 44 49 52 45 43 54 4c 59 2e 20 49 74 20 69 73 DIRECTLY. It is
6170: 20 63 61 6c 6c 65 64 20 66 72 6f 6d 20 63 6f 6d called from com
6180: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 mon:wait-for-nor
6190: 6d 61 6c 69 7a 65 64 2d 6c 6f 61 64 0a 3b 3b 20 malized-load.;;
61a0: 20 20 63 6f 75 6e 74 20 20 20 20 20 2d 20 63 6f count - co
61b0: 75 6e 74 20 64 6f 77 6e 20 74 6f 20 7a 65 72 6f unt down to zero
61c0: 2c 20 61 74 20 73 6f 6d 65 20 70 6f 69 6e 74 20 , at some point
61d0: 77 65 27 64 20 67 69 76 65 20 75 70 20 69 66 20 we'd give up if
61e0: 74 68 65 20 6c 6f 61 64 20 6e 65 76 65 72 20 64 the load never d
61f0: 72 6f 70 73 0a 3b 3b 20 20 20 6e 75 6d 2d 74 72 rops.;; num-tr
6200: 69 65 73 20 2d 20 63 6f 75 6e 74 20 64 6f 77 6e ies - count down
6210: 20 74 6f 20 7a 65 72 6f 20 6e 75 6d 62 65 72 20 to zero number
6220: 74 72 69 65 73 20 74 6f 20 67 65 74 20 6e 75 6d tries to get num
6230: 63 70 75 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 cpus.;;.(define
6240: 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 (common:wait-for
6250: 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6e 6f 72 6d -cpuload maxnorm
6260: 6c 6f 61 64 20 6e 75 6d 63 70 75 73 2d 69 6e 0a load numcpus-in.
6270: 09 09 09 09 20 23 21 6b 65 79 20 28 63 6f 75 6e .... #!key (coun
6280: 74 20 31 30 30 30 29 0a 09 09 09 09 20 28 6d 73 t 1000)..... (ms
6290: 67 20 23 66 29 28 72 65 6d 6f 74 65 2d 68 6f 73 g #f)(remote-hos
62a0: 74 20 23 66 29 28 6e 75 6d 2d 74 72 69 65 73 20 t #f)(num-tries
62b0: 35 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 5)). (let* ((lo
62c0: 61 64 61 76 67 20 20 20 20 20 28 63 6f 6d 6d 6f adavg (commo
62d0: 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 n:get-cpu-load r
62e0: 65 6d 6f 74 65 2d 68 6f 73 74 29 29 0a 20 20 20 emote-host)).
62f0: 20 3b 3b 20 6e 6f 74 20 70 6f 73 73 69 62 6c 65 ;; not possible
6300: 20 74 6f 20 68 61 76 65 20 7a 65 72 6f 2e 20 20 to have zero.
6310: 49 66 20 77 65 20 67 65 74 20 31 2c 20 69 74 27 If we get 1, it'
6320: 73 20 70 6f 73 73 69 62 6c 65 20 74 68 61 74 20 s possible that
6330: 77 65 20 67 6f 74 20 74 68 65 20 70 72 65 76 69 we got the previ
6340: 6f 75 73 20 64 65 66 61 75 6c 74 2c 20 61 6e 64 ous default, and
6350: 20 77 65 20 73 68 6f 75 6c 64 20 63 68 65 63 6b we should check
6360: 20 61 67 61 69 6e 0a 20 20 20 20 28 6e 75 6d 63 again. (numc
6370: 70 75 73 20 20 20 20 20 28 69 66 20 28 3c 3d 20 pus (if (<=
6380: 31 20 6e 75 6d 63 70 75 73 2d 69 6e 29 0a 20 20 1 numcpus-in).
6390: 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 (common:get-nu
63a0: 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f m-cpus remote-ho
63b0: 73 74 29 20 6e 75 6d 63 70 75 73 2d 69 6e 29 29 st) numcpus-in))
63c0: 0a 20 20 20 20 28 66 69 72 73 74 20 20 20 20 20 . (first
63d0: 20 20 28 63 61 72 20 6c 6f 61 64 61 76 67 29 29 (car loadavg))
63e0: 0a 20 20 20 20 28 6e 65 78 74 20 20 20 20 20 20 . (next
63f0: 20 20 28 63 61 64 72 20 6c 6f 61 64 61 76 67 29 (cadr loadavg)
6400: 29 0a 20 20 20 20 28 61 64 6a 6d 61 78 6c 6f 61 ). (adjmaxloa
6410: 64 20 20 28 2a 20 6d 61 78 6e 6f 72 6d 6c 6f 61 d (* maxnormloa
6420: 64 20 28 6d 61 78 20 31 20 6e 75 6d 63 70 75 73 d (max 1 numcpus
6430: 29 29 29 20 3b 3b 20 70 6f 73 73 69 62 6c 65 20 ))) ;; possible
6440: 62 75 67 20 77 68 65 72 65 20 6e 75 6d 63 70 75 bug where numcpu
6450: 73 20 28 6f 72 20 63 6f 75 6c 64 20 62 65 20 6d s (or could be m
6460: 61 78 6c 6f 61 64 29 20 69 73 20 7a 65 72 6f 2c axload) is zero,
6470: 20 63 72 75 64 65 0a 09 09 09 09 09 09 20 20 3b crude....... ;
6480: 3b 20 66 61 6c 6c 62 61 63 6b 20 69 73 20 74 6f ; fallback is to
6490: 20 61 74 20 6c 65 61 73 74 20 75 73 65 20 31 0a at least use 1.
64a0: 20 20 20 20 3b 3b 20 65 66 66 65 63 74 69 76 65 ;; effective
64b0: 20 6c 6f 61 64 20 61 63 63 6f 75 6e 74 73 20 66 load accounts f
64c0: 6f 72 20 6c 6f 61 64 20 6a 75 6d 70 73 2c 20 74 or load jumps, t
64d0: 68 69 73 20 73 68 6f 75 6c 64 20 65 6c 6d 69 6e his should elmin
64e0: 61 74 65 20 61 6c 6c 20 74 68 65 20 66 69 72 73 ate all the firs
64f0: 74 2d 6e 65 78 74 2d 61 76 67 2c 20 61 64 6a 77 t-next-avg, adjw
6500: 61 69 74 2c 20 6c 6f 61 64 2d 6a 75 6d 70 2d 6c ait, load-jump-l
6510: 69 6d 69 74 0a 20 20 20 20 3b 3b 20 65 74 63 2e imit. ;; etc.
6520: 0a 20 20 20 20 28 65 66 66 65 63 74 69 76 65 2d . (effective-
6530: 6c 6f 61 64 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a load (common:
6540: 67 65 74 2d 69 6e 74 65 72 63 65 70 74 20 66 69 get-intercept fi
6550: 72 73 74 20 6e 65 78 74 29 29 0a 20 20 20 20 28 rst next)). (
6560: 72 65 63 6f 6d 6d 65 6e 64 65 64 2d 64 65 6c 61 recommended-dela
6570: 79 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 65 y (common:get-de
6580: 6c 61 79 20 65 66 66 65 63 74 69 76 65 2d 6c 6f lay effective-lo
6590: 61 64 20 6e 75 6d 63 70 75 73 29 29 0a 20 20 20 ad numcpus)).
65a0: 20 28 65 66 66 65 63 74 69 76 65 2d 68 6f 73 74 (effective-host
65b0: 20 20 20 20 28 6f 72 20 72 65 6d 6f 74 65 2d 68 (or remote-h
65c0: 6f 73 74 20 22 6c 6f 63 61 6c 68 6f 73 74 22 29 ost "localhost")
65d0: 29 0a 20 20 20 20 28 6e 6f 72 6d 61 6c 69 7a 65 ). (normalize
65e0: 64 2d 65 66 66 65 63 74 69 76 65 2d 6c 6f 61 64 d-effective-load
65f0: 20 28 2f 20 65 66 66 65 63 74 69 76 65 2d 6c 6f (/ effective-lo
6600: 61 64 20 6e 75 6d 63 70 75 73 29 29 0a 20 20 20 ad numcpus)).
6610: 20 28 77 69 6c 6c 2d 77 61 69 74 20 20 20 20 20 (will-wait
6620: 20 20 20 20 20 20 20 20 20 20 20 20 28 3e 20 6e (> n
6630: 6f 72 6d 61 6c 69 7a 65 64 2d 65 66 66 65 63 74 ormalized-effect
6640: 69 76 65 2d 6c 6f 61 64 20 6d 61 78 6e 6f 72 6d ive-load maxnorm
6650: 6c 6f 61 64 29 29 29 0a 20 20 20 20 28 69 66 20 load))). (if
6660: 28 61 6e 64 20 77 69 6c 6c 2d 77 61 69 74 20 28 (and will-wait (
6670: 3e 20 72 65 63 6f 6d 6d 65 6e 64 65 64 2d 64 65 > recommended-de
6680: 6c 61 79 20 31 29 29 20 0a 20 20 20 20 20 20 28 lay 1)) . (
6690: 6c 65 74 2a 20 28 28 61 63 74 75 61 6c 2d 64 65 let* ((actual-de
66a0: 6c 61 79 20 28 6d 69 6e 20 72 65 63 6f 6d 6d 65 lay (min recomme
66b0: 6e 64 65 64 2d 64 65 6c 61 79 20 33 30 29 29 29 nded-delay 30)))
66c0: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 63 6f . (if (co
66d0: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
66e0: 72 69 6e 74 20 33 30 20 28 63 6f 6e 63 20 28 72 rint 30 (conc (r
66f0: 6f 75 6e 64 20 61 63 74 75 61 6c 2d 64 65 6c 61 ound actual-dela
6700: 79 29 20 22 2d 73 61 66 65 2d 6c 6f 61 64 22 29 y) "-safe-load")
6710: 29 0a 20 20 20 20 20 20 20 20 20 20 28 64 65 62 ). (deb
6720: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
6730: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6740: 74 2a 20 22 4c 6f 61 64 20 63 6f 6e 74 72 6f 6c t* "Load control
6750: 2c 20 64 65 6c 61 79 69 6e 67 20 22 0a 09 09 09 , delaying "....
6760: 09 61 63 74 75 61 6c 2d 64 65 6c 61 79 20 22 20 .actual-delay "
6770: 73 65 63 6f 6e 64 73 20 74 6f 20 6d 61 69 6e 74 seconds to maint
6780: 61 69 6e 20 73 61 66 65 20 6c 6f 61 64 2e 20 63 ain safe load. c
6790: 75 72 72 65 6e 74 20 6e 6f 72 6d 61 6c 69 7a 65 urrent normalize
67a0: 64 20 65 66 66 65 63 74 69 76 65 20 6c 6f 61 64 d effective load
67b0: 20 69 73 20 22 0a 09 09 09 09 6e 6f 72 6d 61 6c is ".....normal
67c0: 69 7a 65 64 2d 65 66 66 65 63 74 69 76 65 2d 6c ized-effective-l
67d0: 6f 61 64 22 2e 20 6d 61 78 6e 6f 72 6d 6c 6f 61 oad". maxnormloa
67e0: 64 20 3d 20 22 20 6d 61 78 6e 6f 72 6d 6c 6f 61 d = " maxnormloa
67f0: 64 20 22 20 6e 75 6d 63 70 75 73 20 3d 20 22 20 d " numcpus = "
6800: 6e 75 6d 63 70 75 73 20 22 20 6c 6f 61 64 61 76 numcpus " loadav
6810: 67 20 3d 20 22 20 6c 6f 61 64 61 76 67 20 22 20 g = " loadavg "
6820: 65 66 66 65 63 74 69 76 65 2d 6c 6f 61 64 20 3d effective-load =
6830: 20 22 20 65 66 66 65 63 74 69 76 65 2d 6c 6f 61 " effective-loa
6840: 64 29 29 0a 09 28 74 68 72 65 61 64 2d 73 6c 65 d))..(thread-sle
6850: 65 70 21 20 61 63 74 75 61 6c 2d 64 65 6c 61 79 ep! actual-delay
6860: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 28 63 6f ))). . (co
6870: 6e 64 0a 20 20 20 20 20 3b 3b 20 62 61 64 20 64 nd. ;; bad d
6880: 61 74 61 2c 20 74 72 79 20 61 67 61 69 6e 20 74 ata, try again t
6890: 6f 20 67 65 74 20 74 68 65 20 64 61 74 61 0a 20 o get the data.
68a0: 20 20 20 20 28 28 6e 6f 74 20 77 69 6c 6c 2d 77 ((not will-w
68b0: 61 69 74 29 0a 20 20 20 20 20 20 28 69 66 20 28 ait). (if (
68c0: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
68d0: 2d 70 72 69 6e 74 20 33 36 30 30 20 28 63 6f 6e -print 3600 (con
68e0: 63 20 28 72 6f 75 6e 64 20 6e 6f 72 6d 61 6c 69 c (round normali
68f0: 7a 65 64 2d 65 66 66 65 63 74 69 76 65 2d 6c 6f zed-effective-lo
6900: 61 64 29 20 22 2d 6c 6f 61 64 2d 61 63 63 65 70 ad) "-load-accep
6910: 74 61 62 6c 65 2d 22 20 65 66 66 65 63 74 69 76 table-" effectiv
6920: 65 2d 68 6f 73 74 29 29 0a 20 20 20 20 20 20 09 e-host)). .
6930: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
6940: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6950: 72 74 2a 20 22 45 66 66 65 63 74 69 76 65 20 6c rt* "Effective l
6960: 6f 61 64 20 6f 6e 20 22 20 65 66 66 65 63 74 69 oad on " effecti
6970: 76 65 2d 68 6f 73 74 20 22 20 69 73 20 61 63 63 ve-host " is acc
6980: 65 70 74 61 62 6c 65 20 61 74 20 22 20 65 66 66 eptable at " eff
6990: 65 63 74 69 76 65 2d 6c 6f 61 64 20 22 20 63 6f ective-load " co
69a0: 6e 74 69 6e 75 69 6e 67 2e 22 29 29 29 0a 0a 20 ntinuing.")))..
69b0: 20 20 20 20 28 28 61 6e 64 20 28 3c 20 66 69 72 ((and (< fir
69c0: 73 74 20 30 29 20 3b 3b 20 74 68 69 73 20 69 6e st 0) ;; this in
69d0: 64 69 63 61 74 65 73 20 74 68 65 20 6c 6f 61 64 dicates the load
69e0: 61 76 67 20 64 61 74 61 20 69 73 20 62 61 64 20 avg data is bad
69f0: 2d 20 6d 61 63 68 69 6e 65 20 6d 61 79 20 6e 6f - machine may no
6a00: 74 20 62 65 20 72 65 61 63 68 61 62 6c 65 0a 09 t be reachable..
6a10: 20 20 20 28 3e 20 6e 75 6d 2d 74 72 69 65 73 20 (> num-tries
6a20: 30 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 0)). (debug
6a30: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
6a40: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
6a50: 4e 49 4e 47 3a 20 72 65 63 65 69 76 65 64 20 62 NING: received b
6a60: 61 64 20 64 61 74 61 20 66 72 6f 6d 20 67 65 74 ad data from get
6a70: 2d 63 70 75 2d 6c 6f 61 64 20 22 0a 09 09 20 20 -cpu-load "...
6a80: 20 66 69 72 73 74 20 22 2c 20 77 65 27 6c 6c 20 first ", we'll
6a90: 73 6c 65 65 70 20 31 30 73 20 61 6e 64 20 74 72 sleep 10s and tr
6aa0: 79 20 22 20 6e 75 6d 2d 74 72 69 65 73 20 22 20 y " num-tries "
6ab0: 6d 6f 72 65 20 74 69 6d 65 73 2e 22 29 0a 20 20 more times.").
6ac0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
6ad0: 70 21 20 31 30 29 0a 20 20 20 20 20 20 28 63 6f p! 10). (co
6ae0: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 mmon:wait-for-cp
6af0: 75 6c 6f 61 64 20 6d 61 78 6e 6f 72 6d 6c 6f 61 uload maxnormloa
6b00: 64 20 6e 75 6d 63 70 75 73 2d 69 6e 0a 09 09 09 d numcpus-in....
6b10: 20 20 20 20 20 20 20 63 6f 75 6e 74 3a 20 63 6f count: co
6b20: 75 6e 74 20 72 65 6d 6f 74 65 2d 68 6f 73 74 3a unt remote-host:
6b30: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 6e 75 6d remote-host num
6b40: 2d 74 72 69 65 73 3a 20 28 2d 20 6e 75 6d 2d 74 -tries: (- num-t
6b50: 72 69 65 73 20 31 29 29 29 0a 0a 20 20 20 20 20 ries 1)))..
6b60: 3b 3b 20 6e 65 65 64 20 74 6f 20 77 61 69 74 20 ;; need to wait
6b70: 66 6f 72 20 6c 6f 61 64 20 74 6f 20 64 72 6f 70 for load to drop
6b80: 0a 20 20 20 20 20 28 28 61 6e 64 20 77 69 6c 6c . ((and will
6b90: 2d 77 61 69 74 20 3b 3b 20 28 3e 20 66 69 72 73 -wait ;; (> firs
6ba0: 74 20 61 64 6a 6d 61 78 6c 6f 61 64 29 0a 09 20 t adjmaxload)..
6bb0: 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 (> count 0)).
6bc0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6bd0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
6be0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 09 22 t-log-port*...."
6bf0: 44 65 6c 61 79 69 6e 67 20 31 35 22 20 3b 3b 20 Delaying 15" ;;
6c00: 61 64 6a 77 61 69 74 0a 09 09 09 22 20 73 65 63 adjwait...." sec
6c10: 6f 6e 64 73 20 64 75 65 20 74 6f 20 6e 6f 72 6d onds due to norm
6c20: 61 6c 69 7a 65 64 20 65 66 66 65 63 74 69 76 65 alized effective
6c30: 20 6c 6f 61 64 20 22 20 6e 6f 72 6d 61 6c 69 7a load " normaliz
6c40: 65 64 2d 65 66 66 65 63 74 69 76 65 2d 6c 6f 61 ed-effective-loa
6c50: 64 20 3b 3b 20 66 69 72 73 74 0a 09 09 09 22 20 d ;; first...."
6c60: 65 78 63 65 65 64 69 6e 67 20 6d 61 78 20 6f 66 exceeding max of
6c70: 20 22 20 61 64 6a 6d 61 78 6c 6f 61 64 0a 09 09 " adjmaxload...
6c80: 09 22 20 6f 6e 20 73 65 72 76 65 72 20 22 20 28 ." on server " (
6c90: 6f 72 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 28 or remote-host (
6ca0: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a get-host-name)).
6cb0: 09 09 09 22 20 28 6e 6f 72 6d 61 6c 69 7a 65 64 ..." (normalized
6cc0: 20 6c 6f 61 64 2d 6c 69 6d 69 74 3a 20 22 20 6d load-limit: " m
6cd0: 61 78 6e 6f 72 6d 6c 6f 61 64 20 22 29 20 22 20 axnormload ") "
6ce0: 28 69 66 20 6d 73 67 20 6d 73 67 20 22 22 29 29 (if msg msg ""))
6cf0: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
6d00: 6c 65 65 70 21 20 31 35 29 20 3b 3b 20 61 64 6a leep! 15) ;; adj
6d10: 77 61 69 74 29 0a 20 20 20 20 20 20 28 63 6f 6d wait). (com
6d20: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 mon:wait-for-cpu
6d30: 6c 6f 61 64 20 6d 61 78 6e 6f 72 6d 6c 6f 61 64 load maxnormload
6d40: 20 6e 75 6d 63 70 75 73 20 63 6f 75 6e 74 3a 20 numcpus count:
6d50: 28 2d 20 63 6f 75 6e 74 20 31 29 20 6d 73 67 3a (- count 1) msg:
6d60: 20 6d 73 67 20 72 65 6d 6f 74 65 2d 68 6f 73 74 msg remote-host
6d70: 3a 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 : remote-host).
6d80: 20 20 20 20 20 3b 3b 20 70 75 74 20 74 68 65 20 ;; put the
6d90: 6d 65 73 73 61 67 65 20 68 65 72 65 20 74 6f 20 message here to
6da0: 69 6e 64 69 63 61 74 65 20 63 61 6d 65 20 6f 75 indicate came ou
6db0: 74 20 6f 66 20 77 61 69 74 69 6e 67 0a 20 20 20 t of waiting.
6dc0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
6dd0: 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d info 1 *default-
6de0: 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 09 22 4f 6e log-port*...."On
6df0: 20 68 6f 73 74 3a 20 22 20 65 66 66 65 63 74 69 host: " effecti
6e00: 76 65 2d 68 6f 73 74 0a 09 09 09 22 2c 20 65 66 ve-host....", ef
6e10: 66 65 63 74 69 76 65 20 6c 6f 61 64 3a 20 22 20 fective load: "
6e20: 65 66 66 65 63 74 69 76 65 2d 6c 6f 61 64 0a 09 effective-load..
6e30: 09 09 22 2c 20 6e 75 6d 63 70 75 73 3a 20 22 20 ..", numcpus: "
6e40: 6e 75 6d 63 70 75 73 0a 09 09 09 22 2c 20 6e 6f numcpus....", no
6e50: 72 6d 61 6c 69 7a 65 64 20 65 66 66 65 63 74 69 rmalized effecti
6e60: 76 65 20 6c 6f 61 64 3a 20 22 20 6e 6f 72 6d 61 ve load: " norma
6e70: 6c 69 7a 65 64 2d 65 66 66 65 63 74 69 76 65 2d lized-effective-
6e80: 6c 6f 61 64 0a 09 09 09 29 29 0a 20 20 20 20 20 load....)).
6e90: 3b 3b 20 6f 76 65 72 6c 6f 61 64 65 64 20 61 6e ;; overloaded an
6ea0: 64 20 63 6f 75 6e 74 20 65 78 70 69 72 65 64 20 d count expired
6eb0: 28 69 2e 65 2e 20 77 65 6e 74 20 74 6f 20 7a 65 (i.e. went to ze
6ec0: 72 6f 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 ro). (else.
6ed0: 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 2d (if (> num-
6ee0: 74 72 69 65 73 20 30 29 20 3b 3b 20 73 68 6f 75 tries 0) ;; shou
6ef0: 6c 64 20 62 65 20 22 6e 75 6d 2d 74 72 69 65 73 ld be "num-tries
6f00: 2d 6c 65 66 74 22 2e 20 0a 09 20 20 28 69 66 20 -left". .. (if
6f10: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
6f20: 65 2d 70 72 69 6e 74 20 33 30 20 28 63 6f 6e 63 e-print 30 (conc
6f30: 20 28 72 6f 75 6e 64 20 65 66 66 65 63 74 69 76 (round effectiv
6f40: 65 2d 6c 6f 61 64 29 20 22 2d 6c 6f 61 64 2d 61 e-load) "-load-a
6f50: 63 63 65 70 74 61 62 6c 65 2d 22 20 65 66 66 65 cceptable-" effe
6f60: 63 74 69 76 65 2d 68 6f 73 74 29 29 0a 09 20 20 ctive-host))..
6f70: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6f80: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6f90: 70 6f 72 74 2a 20 22 4c 6f 61 64 20 6f 6e 20 22 port* "Load on "
6fa0: 20 65 66 66 65 63 74 69 76 65 2d 68 6f 73 74 20 effective-host
6fb0: 22 20 69 73 20 61 63 63 65 70 74 61 62 6c 65 20 " is acceptable
6fc0: 61 74 20 65 66 66 65 63 74 69 76 65 20 6e 6f 72 at effective nor
6fd0: 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 20 6f 66 20 malized load of
6fe0: 22 0a 09 09 09 20 20 20 6e 6f 72 6d 61 6c 69 7a ".... normaliz
6ff0: 65 64 2d 65 66 66 65 63 74 69 76 65 2d 6c 6f 61 ed-effective-loa
7000: 64 20 22 20 20 63 6f 6e 74 69 6e 75 69 6e 67 2e d " continuing.
7010: 22 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 ")).. (debug:pr
7020: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
7030: 6f 67 2d 70 6f 72 74 2a 20 22 4c 6f 61 64 20 6f og-port* "Load o
7040: 6e 20 22 20 65 66 66 65 63 74 69 76 65 2d 68 6f n " effective-ho
7050: 73 74 20 22 2c 20 22 0a 09 09 20 20 20 20 20 20 st ", "...
7060: 20 66 69 72 73 74 22 20 63 6f 75 6c 64 20 6e 6f first" could no
7070: 74 20 62 65 20 72 65 74 72 69 65 76 65 64 2e 20 t be retrieved.
7080: 47 69 76 69 6e 67 20 75 70 20 61 6e 64 20 63 6f Giving up and co
7090: 6e 74 69 6e 75 69 6e 67 2e 22 29 29 29 29 29 29 ntinuing."))))))
70a0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
70b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 4f ==========.;; DO
70f0: 20 4e 4f 54 20 43 41 4c 4c 20 54 48 49 53 20 44 NOT CALL THIS D
7100: 49 52 45 43 54 4c 59 2e 20 49 74 20 69 73 20 63 IRECTLY. It is c
7110: 61 6c 6c 65 64 20 66 72 6f 6d 20 63 6f 6d 6d 6f alled from commo
7120: 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 n:wait-for-norma
7130: 6c 69 7a 65 64 2d 6c 6f 61 64 0a 3b 3b 0a 3b 3b lized-load.;;.;;
7140: 20 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e (define (common
7150: 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 :wait-for-cpuloa
7160: 64 20 6d 61 78 6c 6f 61 64 2d 69 6e 20 6e 75 6d d maxload-in num
7170: 63 70 75 73 2d 69 6e 20 77 61 69 74 64 65 6c 61 cpus-in waitdela
7180: 79 20 23 21 6b 65 79 20 28 63 6f 75 6e 74 20 31 y #!key (count 1
7190: 30 30 30 29 20 28 6d 73 67 20 23 66 29 28 72 65 000) (msg #f)(re
71a0: 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 28 66 6f mote-host #f)(fo
71b0: 72 63 65 2d 6d 61 78 6c 6f 61 64 20 23 66 29 28 rce-maxload #f)(
71c0: 6e 75 6d 2d 74 72 69 65 73 20 35 29 29 0a 3b 3b num-tries 5)).;;
71d0: 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 61 (let* ((loada
71e0: 76 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 vg (common:get-c
71f0: 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 pu-load remote-h
7200: 6f 73 74 29 29 0a 3b 3b 20 09 20 28 6e 75 6d 63 ost)).;; . (numc
7210: 70 75 73 20 28 69 66 20 28 3c 3d 20 31 20 6e 75 pus (if (<= 1 nu
7220: 6d 63 70 75 73 2d 69 6e 29 20 3b 3b 20 6e 6f 74 mcpus-in) ;; not
7230: 20 70 6f 73 73 69 62 6c 65 20 74 6f 20 68 61 76 possible to hav
7240: 65 20 7a 65 72 6f 2e 20 20 49 66 20 77 65 20 67 e zero. If we g
7250: 65 74 20 31 2c 20 69 74 27 73 20 70 6f 73 73 69 et 1, it's possi
7260: 62 6c 65 20 74 68 61 74 20 77 65 20 67 6f 74 20 ble that we got
7270: 74 68 65 20 70 72 65 76 69 6f 75 73 20 64 65 66 the previous def
7280: 61 75 6c 74 2c 20 61 6e 64 20 77 65 20 73 68 6f ault, and we sho
7290: 75 6c 64 20 63 68 65 63 6b 20 61 67 61 69 6e 0a uld check again.
72a0: 3b 3b 20 09 09 20 20 20 20 20 20 28 63 6f 6d 6d ;; .. (comm
72b0: 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 73 20 on:get-num-cpus
72c0: 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 3b 3b 20 remote-host).;;
72d0: 09 09 20 20 20 20 20 20 6e 75 6d 63 70 75 73 2d .. numcpus-
72e0: 69 6e 29 29 0a 3b 3b 20 09 20 28 6d 61 78 6c 6f in)).;; . (maxlo
72f0: 61 64 20 28 69 66 20 66 6f 72 63 65 2d 6d 61 78 ad (if force-max
7300: 6c 6f 61 64 0a 3b 3b 20 09 09 20 20 20 20 20 20 load.;; ..
7310: 6d 61 78 6c 6f 61 64 2d 69 6e 0a 3b 3b 20 09 09 maxload-in.;; ..
7320: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 65 (if (numbe
7330: 72 3f 20 6d 61 78 6c 6f 61 64 2d 69 6e 29 0a 3b r? maxload-in).;
7340: 3b 20 09 09 09 20 20 28 6d 61 78 20 6d 61 78 6c ; ... (max maxl
7350: 6f 61 64 2d 69 6e 20 30 2e 35 29 0a 3b 3b 20 09 oad-in 0.5).;; .
7360: 09 09 20 20 30 2e 35 29 29 29 20 3b 3b 20 73 6f .. 0.5))) ;; so
7370: 20 6d 61 78 6c 6f 61 64 20 6d 75 73 74 20 62 65 maxload must be
7380: 20 67 72 65 61 74 65 72 20 74 68 61 6e 20 30 2e greater than 0.
7390: 35 20 66 6f 72 20 6e 6f 77 20 42 55 47 20 2d 20 5 for now BUG -
73a0: 46 49 58 4d 45 3f 0a 3b 3b 20 09 20 28 66 69 72 FIXME?.;; . (fir
73b0: 73 74 20 20 20 28 63 61 72 20 6c 6f 61 64 61 76 st (car loadav
73c0: 67 29 29 0a 3b 3b 20 09 20 28 6e 65 78 74 20 20 g)).;; . (next
73d0: 20 20 28 63 61 64 72 20 6c 6f 61 64 61 76 67 29 (cadr loadavg)
73e0: 29 0a 3b 3b 20 09 20 28 61 64 6a 6d 61 78 6c 6f ).;; . (adjmaxlo
73f0: 61 64 20 28 2a 20 6d 61 78 6c 6f 61 64 20 28 6d ad (* maxload (m
7400: 61 78 20 31 20 6e 75 6d 63 70 75 73 29 29 29 20 ax 1 numcpus)))
7410: 3b 3b 20 70 6f 73 73 69 62 6c 65 20 62 75 67 20 ;; possible bug
7420: 77 68 65 72 65 0a 3b 3b 20 09 09 09 09 09 20 20 where.;; .....
7430: 20 20 20 20 20 3b 3b 20 6e 75 6d 63 70 75 73 20 ;; numcpus
7440: 28 6f 72 20 63 6f 75 6c 64 20 62 65 0a 3b 3b 20 (or could be.;;
7450: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 6d ..... ;; m
7460: 61 78 6c 6f 61 64 29 20 69 73 20 7a 65 72 6f 2c axload) is zero,
7470: 0a 3b 3b 20 09 09 09 09 09 20 20 20 20 20 20 20 .;; .....
7480: 3b 3b 20 63 72 75 64 65 20 66 61 6c 6c 62 61 63 ;; crude fallbac
7490: 6b 20 69 73 20 74 6f 0a 3b 3b 20 09 09 09 09 09 k is to.;; .....
74a0: 20 20 20 20 20 20 20 3b 3b 20 61 74 20 6c 65 61 ;; at lea
74b0: 73 74 20 75 73 65 20 31 0a 3b 3b 20 09 20 28 6c st use 1.;; . (l
74c0: 6f 61 64 6a 6d 70 20 28 2d 20 66 69 72 73 74 20 oadjmp (- first
74d0: 28 69 66 20 28 3e 20 6e 65 78 74 20 28 2a 20 6e (if (> next (* n
74e0: 75 6d 63 70 75 73 20 30 2e 37 29 29 20 3b 3b 20 umcpus 0.7)) ;;
74f0: 63 6f 75 6c 64 20 64 6f 20 73 6f 6d 65 74 68 69 could do somethi
7500: 6e 67 20 77 69 74 68 20 61 76 65 72 61 67 65 20 ng with average
7510: 6f 66 20 66 69 72 73 74 20 61 6e 64 20 6e 65 78 of first and nex
7520: 74 3f 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 20 t?.;; ...
7530: 30 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 20 6e 0.;; ... n
7540: 65 78 74 29 29 29 20 3b 3b 20 77 65 20 77 69 6c ext))) ;; we wil
7550: 6c 20 66 6f 72 63 65 20 61 20 63 6f 6e 73 65 72 l force a conser
7560: 76 61 74 69 76 65 20 63 61 6c 63 75 6c 61 74 69 vative calculati
7570: 6f 6e 20 61 6e 79 20 74 69 6d 65 20 6e 65 78 74 on any time next
7580: 20 69 73 20 6c 61 72 67 65 2e 0a 3b 3b 20 09 20 is large..;; .
7590: 28 66 69 72 73 74 2d 6e 65 78 74 2d 61 76 67 20 (first-next-avg
75a0: 20 20 20 28 2f 20 28 2b 20 66 69 72 73 74 20 6e (/ (+ first n
75b0: 65 78 74 29 20 32 29 29 0a 3b 3b 20 09 20 3b 3b ext) 2)).;; . ;;
75c0: 20 61 64 64 20 73 6f 6d 65 20 72 61 6e 64 6f 6d add some random
75d0: 6e 65 73 73 20 74 6f 20 74 68 65 20 74 69 6d 65 ness to the time
75e0: 20 74 6f 20 62 72 65 61 6b 20 61 6e 79 20 61 6c to break any al
75f0: 69 67 6e 6d 65 6e 74 0a 3b 3b 20 09 20 3b 3b 20 ignment.;; . ;;
7600: 77 68 65 72 65 20 6e 65 74 62 61 74 63 68 20 64 where netbatch d
7610: 75 6d 70 73 20 6d 61 6e 79 20 6a 6f 62 73 20 74 umps many jobs t
7620: 6f 20 6d 61 63 68 69 6e 65 73 20 73 69 6d 75 6c o machines simul
7630: 74 61 6e 65 6f 75 73 6c 79 0a 3b 3b 20 20 20 20 taneously.;;
7640: 20 20 20 20 20 20 28 61 64 6a 77 61 69 74 20 20 (adjwait
7650: 20 20 20 20 20 20 20 20 20 28 6d 69 6e 20 28 2b (min (+
7660: 20 33 30 30 20 28 72 61 6e 64 6f 6d 20 31 30 29 300 (random 10)
7670: 29 20 28 61 62 73 20 28 2a 20 28 2b 20 28 72 61 ) (abs (* (+ (ra
7680: 6e 64 6f 6d 20 31 30 29 0a 3b 3b 20 09 09 09 09 ndom 10).;; ....
7690: 09 09 09 09 28 2f 20 28 2d 20 31 30 30 30 20 63 ....(/ (- 1000 c
76a0: 6f 75 6e 74 29 20 31 30 29 0a 3b 3b 20 09 09 09 ount) 10).;; ...
76b0: 09 09 09 09 09 77 61 69 74 64 65 6c 61 79 29 0a .....waitdelay).
76c0: 3b 3b 20 09 09 09 09 09 09 09 20 20 20 20 20 28 ;; ....... (
76d0: 2d 20 66 69 72 73 74 20 61 64 6a 6d 61 78 6c 6f - first adjmaxlo
76e0: 61 64 29 20 29 29 29 29 0a 3b 3b 20 09 20 28 6c ad) )))).;; . (l
76f0: 6f 61 64 2d 6a 75 6d 70 2d 6c 69 6d 69 74 20 20 oad-jump-limit
7700: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
7710: 2d 6e 75 6d 62 65 72 20 2a 63 6f 6e 66 69 67 64 -number *configd
7720: 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c 6f 61 at* "setup" "loa
7730: 64 2d 6a 75 6d 70 2d 6c 69 6d 69 74 22 29 29 0a d-jump-limit")).
7740: 3b 3b 20 09 20 3b 3b 20 65 66 66 65 63 74 69 76 ;; . ;; effectiv
7750: 65 20 6c 6f 61 64 20 61 63 63 6f 75 6e 74 73 20 e load accounts
7760: 66 6f 72 20 6c 6f 61 64 20 6a 75 6d 70 73 2c 20 for load jumps,
7770: 74 68 69 73 20 73 68 6f 75 6c 64 20 65 6c 6d 69 this should elmi
7780: 6e 61 74 65 20 61 6c 6c 20 74 68 65 20 66 69 72 nate all the fir
7790: 73 74 2d 6e 65 78 74 2d 61 76 67 2c 20 61 64 6a st-next-avg, adj
77a0: 77 61 69 74 2c 20 6c 6f 61 64 2d 6a 75 6d 70 2d wait, load-jump-
77b0: 6c 69 6d 69 74 0a 3b 3b 20 09 20 3b 3b 20 65 74 limit.;; . ;; et
77c0: 63 2e 0a 3b 3b 20 09 20 28 65 66 66 65 63 74 69 c..;; . (effecti
77d0: 76 65 2d 6c 6f 61 64 20 20 20 20 28 63 6f 6d 6d ve-load (comm
77e0: 6f 6e 3a 67 65 74 2d 69 6e 74 65 72 63 65 70 74 on:get-intercept
77f0: 20 66 69 72 73 74 20 6e 65 78 74 29 29 0a 3b 3b first next)).;;
7800: 20 09 20 28 65 66 66 65 63 74 69 76 65 2d 68 6f . (effective-ho
7810: 73 74 20 20 20 20 28 6f 72 20 72 65 6d 6f 74 65 st (or remote
7820: 2d 68 6f 73 74 20 22 6c 6f 63 61 6c 68 6f 73 74 -host "localhost
7830: 22 29 29 0a 3b 3b 20 09 20 28 6e 6f 72 6d 61 6c ")).;; . (normal
7840: 69 7a 65 64 2d 65 66 66 65 63 74 69 76 65 2d 6c ized-effective-l
7850: 6f 61 64 20 28 2f 20 65 66 66 65 63 74 69 76 65 oad (/ effective
7860: 2d 6c 6f 61 64 20 6e 75 6d 63 70 75 73 29 29 0a -load numcpus)).
7870: 3b 3b 20 09 20 28 77 69 6c 6c 2d 77 61 69 74 20 ;; . (will-wait
7880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7890: 28 3e 20 6e 6f 72 6d 61 6c 69 7a 65 64 2d 65 66 (> normalized-ef
78a0: 66 65 63 74 69 76 65 2d 6c 6f 61 64 20 6d 61 78 fective-load max
78b0: 6c 6f 61 64 29 29 29 0a 3b 3b 20 09 20 0a 3b 3b load))).;; . .;;
78c0: 20 20 20 20 20 3b 3b 20 6c 65 74 27 73 20 6c 65 ;; let's le
78d0: 74 20 74 68 65 20 75 73 65 72 20 6b 6e 6f 77 20 t the user know
78e0: 6f 6e 63 65 20 69 6e 20 61 20 6c 6f 6e 67 20 77 once in a long w
78f0: 68 69 6c 65 20 74 68 61 74 20 6c 6f 61 64 20 63 hile that load c
7900: 68 65 63 6b 69 6e 67 0a 3b 3b 20 20 20 20 20 3b hecking.;; ;
7910: 3b 20 69 73 20 68 61 70 70 65 6e 69 6e 67 20 62 ; is happening b
7920: 75 74 20 6e 6f 74 20 63 6f 6e 73 74 61 6e 74 6c ut not constantl
7930: 79 20 72 65 70 6f 72 74 20 69 74 0a 3b 3b 20 20 y report it.;;
7940: 20 20 20 23 3b 28 69 66 20 28 63 6f 6d 6d 6f 6e #;(if (common
7950: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
7960: 20 33 30 20 28 63 6f 6e 63 20 22 63 70 75 6c 6f 30 (conc "cpulo
7970: 61 64 22 20 28 6f 72 20 72 65 6d 6f 74 65 2d 68 ad" (or remote-h
7980: 6f 73 74 20 22 6c 6f 63 61 6c 68 6f 73 74 22 29 ost "localhost")
7990: 29 29 20 3b 3b 20 28 3e 20 28 72 61 6e 64 6f 6d )) ;; (> (random
79a0: 20 31 30 30 29 20 37 35 29 20 3b 3b 20 61 62 6f 100) 75) ;; abo
79b0: 75 74 20 32 35 25 20 6f 66 20 74 68 65 20 74 69 ut 25% of the ti
79c0: 6d 65 0a 3b 3b 20 09 28 64 65 62 75 67 3a 70 72 me.;; .(debug:pr
79d0: 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 int-info 1 *defa
79e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 ult-log-port* "C
79f0: 68 65 63 6b 69 6e 67 20 63 70 75 6c 6f 61 64 20 hecking cpuload
7a00: 6f 6e 20 22 20 28 6f 72 20 72 65 6d 6f 74 65 2d on " (or remote-
7a10: 68 6f 73 74 20 22 6c 6f 63 61 6c 68 6f 73 74 22 host "localhost"
7a20: 29 20 22 2c 20 6d 61 78 6c 6f 61 64 3a 20 22 20 ) ", maxload: "
7a30: 6d 61 78 6c 6f 61 64 0a 3b 3b 20 20 20 20 20 22 maxload.;; "
7a40: 2c 20 6c 6f 61 64 3a 20 22 20 66 69 72 73 74 20 , load: " first
7a50: 22 2c 20 61 64 6a 6d 61 78 6c 6f 61 64 3a 20 22 ", adjmaxload: "
7a60: 20 61 64 6a 6d 61 78 6c 6f 61 64 20 22 2c 20 6c adjmaxload ", l
7a70: 6f 61 64 6a 6d 70 3a 20 22 20 6c 6f 61 64 6a 6d oadjmp: " loadjm
7a80: 70 29 29 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 28 p)).;; .;; (
7a90: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7aa0: 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
7ab0: 70 6f 72 74 2a 0a 3b 3b 20 09 09 20 20 20 20 20 port*.;; ..
7ac0: 20 22 4f 6e 20 68 6f 73 74 3a 20 22 20 65 66 66 "On host: " eff
7ad0: 65 63 74 69 76 65 2d 68 6f 73 74 0a 3b 3b 20 09 ective-host.;; .
7ae0: 09 20 20 20 20 20 20 22 2c 20 65 66 66 65 63 74 . ", effect
7af0: 69 76 65 20 6c 6f 61 64 3a 20 22 20 65 66 66 65 ive load: " effe
7b00: 63 74 69 76 65 2d 6c 6f 61 64 0a 3b 3b 20 09 09 ctive-load.;; ..
7b10: 20 20 20 20 20 20 22 2c 20 6e 75 6d 63 70 75 73 ", numcpus
7b20: 3a 20 22 20 6e 75 6d 63 70 75 73 0a 3b 3b 20 09 : " numcpus.;; .
7b30: 09 20 20 20 20 20 20 22 2c 20 6e 6f 72 6d 61 6c . ", normal
7b40: 69 7a 65 64 20 65 66 66 65 63 74 69 76 65 20 6c ized effective l
7b50: 6f 61 64 3a 20 22 20 6e 6f 72 6d 61 6c 69 7a 65 oad: " normalize
7b60: 64 2d 65 66 66 65 63 74 69 76 65 2d 6c 6f 61 64 d-effective-load
7b70: 0a 3b 3b 20 09 09 20 20 20 20 20 20 29 0a 3b 3b .;; .. ).;;
7b80: 20 20 20 20 20 0a 3b 3b 20 20 20 20 20 28 63 6f .;; (co
7b90: 6e 64 0a 3b 3b 20 20 20 20 20 20 3b 3b 20 62 61 nd.;; ;; ba
7ba0: 64 20 64 61 74 61 2c 20 74 72 79 20 61 67 61 69 d data, try agai
7bb0: 6e 20 74 6f 20 67 65 74 20 74 68 65 20 64 61 74 n to get the dat
7bc0: 61 0a 3b 3b 20 20 20 20 20 20 28 28 61 6e 64 20 a.;; ((and
7bd0: 28 3c 20 66 69 72 73 74 20 30 29 20 3b 3b 20 74 (< first 0) ;; t
7be0: 68 69 73 20 69 6e 64 69 63 61 74 65 73 20 74 68 his indicates th
7bf0: 65 20 6c 6f 61 64 61 76 67 20 64 61 74 61 20 69 e loadavg data i
7c00: 73 20 62 61 64 20 2d 20 6d 61 63 68 69 6e 65 20 s bad - machine
7c10: 6d 61 79 20 6e 6f 74 20 62 65 20 72 65 61 63 68 may not be reach
7c20: 61 62 6c 65 0a 3b 3b 20 09 20 20 20 28 3e 20 6e able.;; . (> n
7c30: 75 6d 2d 74 72 69 65 73 20 30 29 29 0a 3b 3b 20 um-tries 0)).;;
7c40: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7c50: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
7c60: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
7c70: 3a 20 72 65 63 65 69 76 65 64 20 62 61 64 20 64 : received bad d
7c80: 61 74 61 20 66 72 6f 6d 20 67 65 74 2d 63 70 75 ata from get-cpu
7c90: 2d 6c 6f 61 64 20 22 20 66 69 72 73 74 20 22 2c -load " first ",
7ca0: 20 77 65 27 6c 6c 20 73 6c 65 65 70 20 31 30 73 we'll sleep 10s
7cb0: 20 61 6e 64 20 74 72 79 20 22 20 6e 75 6d 2d 74 and try " num-t
7cc0: 72 69 65 73 20 22 20 6d 6f 72 65 20 74 69 6d 65 ries " more time
7cd0: 73 2e 22 29 0a 3b 3b 20 20 20 20 20 20 20 28 74 s.").;; (t
7ce0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 30 29 hread-sleep! 10)
7cf0: 0a 3b 3b 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f .;; (commo
7d00: 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f n:wait-for-cpulo
7d10: 61 64 20 6d 61 78 6c 6f 61 64 2d 69 6e 20 6e 75 ad maxload-in nu
7d20: 6d 63 70 75 73 2d 69 6e 20 77 61 69 74 64 65 6c mcpus-in waitdel
7d30: 61 79 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 20 ay.;; ...
7d40: 63 6f 75 6e 74 3a 20 63 6f 75 6e 74 20 72 65 6d count: count rem
7d50: 6f 74 65 2d 68 6f 73 74 3a 20 72 65 6d 6f 74 65 ote-host: remote
7d60: 2d 68 6f 73 74 20 66 6f 72 63 65 2d 6d 61 78 6c -host force-maxl
7d70: 6f 61 64 3a 20 66 6f 72 63 65 2d 6d 61 78 6c 6f oad: force-maxlo
7d80: 61 64 20 6e 75 6d 2d 74 72 69 65 73 3a 20 28 2d ad num-tries: (-
7d90: 20 6e 75 6d 2d 74 72 69 65 73 20 31 29 29 29 0a num-tries 1))).
7da0: 3b 3b 20 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 ;; ;; need
7db0: 74 6f 20 77 61 69 74 20 66 6f 72 20 6c 6f 61 64 to wait for load
7dc0: 20 74 6f 20 64 72 6f 70 0a 3b 3b 20 20 20 20 20 to drop.;;
7dd0: 20 28 28 61 6e 64 20 77 69 6c 6c 2d 77 61 69 74 ((and will-wait
7de0: 20 3b 3b 20 28 3e 20 66 69 72 73 74 20 61 64 6a ;; (> first adj
7df0: 6d 61 78 6c 6f 61 64 29 0a 3b 3b 20 09 20 20 20 maxload).;; .
7e00: 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 3b 3b 20 (> count 0)).;;
7e10: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7e20: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
7e30: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 3b 3b 20 lt-log-port*.;;
7e40: 09 09 09 22 44 65 6c 61 79 69 6e 67 20 22 20 31 ..."Delaying " 1
7e50: 35 20 3b 3b 20 61 64 6a 77 61 69 74 0a 3b 3b 20 5 ;; adjwait.;;
7e60: 09 09 09 22 20 73 65 63 6f 6e 64 73 20 64 75 65 ..." seconds due
7e70: 20 74 6f 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 65 to normalized e
7e80: 66 66 65 63 74 69 76 65 20 6c 6f 61 64 20 22 20 ffective load "
7e90: 6e 6f 72 6d 61 6c 69 7a 65 64 2d 65 66 66 65 63 normalized-effec
7ea0: 74 69 76 65 2d 6c 6f 61 64 20 3b 3b 20 66 69 72 tive-load ;; fir
7eb0: 73 74 0a 3b 3b 20 09 09 09 22 20 65 78 63 65 65 st.;; ..." excee
7ec0: 64 69 6e 67 20 6d 61 78 20 6f 66 20 22 20 61 64 ding max of " ad
7ed0: 6a 6d 61 78 6c 6f 61 64 0a 3b 3b 20 09 09 09 22 jmaxload.;; ..."
7ee0: 20 6f 6e 20 73 65 72 76 65 72 20 22 20 28 6f 72 on server " (or
7ef0: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 28 67 65 remote-host (ge
7f00: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 3b 3b t-host-name)).;;
7f10: 20 09 09 09 22 20 28 6e 6f 72 6d 61 6c 69 7a 65 ..." (normalize
7f20: 64 20 6c 6f 61 64 2d 6c 69 6d 69 74 3a 20 22 20 d load-limit: "
7f30: 6d 61 78 6c 6f 61 64 20 22 29 20 22 20 28 69 66 maxload ") " (if
7f40: 20 6d 73 67 20 6d 73 67 20 22 22 29 29 0a 3b 3b msg msg "")).;;
7f50: 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 (thread-s
7f60: 6c 65 65 70 21 20 31 35 29 20 3b 3b 20 61 64 6a leep! 15) ;; adj
7f70: 77 61 69 74 29 0a 3b 3b 20 20 20 20 20 20 20 28 wait).;; (
7f80: 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d common:wait-for-
7f90: 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 cpuload maxload
7fa0: 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 numcpus waitdela
7fb0: 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e y count: (- coun
7fc0: 74 20 31 29 20 6d 73 67 3a 20 6d 73 67 20 72 65 t 1) msg: msg re
7fd0: 6d 6f 74 65 2d 68 6f 73 74 3a 20 72 65 6d 6f 74 mote-host: remot
7fe0: 65 2d 68 6f 73 74 29 29 0a 3b 3b 20 20 20 20 20 e-host)).;;
7ff0: 20 28 28 61 6e 64 20 28 3e 20 6c 6f 61 64 6a 6d ((and (> loadjm
8000: 70 20 28 63 6f 6e 64 0a 3b 3b 20 09 09 20 20 20 p (cond.;; ..
8010: 20 20 20 20 28 6c 6f 61 64 2d 6a 75 6d 70 2d 6c (load-jump-l
8020: 69 6d 69 74 20 6c 6f 61 64 2d 6a 75 6d 70 2d 6c imit load-jump-l
8030: 69 6d 69 74 29 0a 3b 3b 20 09 09 20 20 20 20 20 imit).;; ..
8040: 20 20 28 28 3e 20 6e 75 6d 63 70 75 73 20 38 29 ((> numcpus 8)
8050: 28 2f 20 6e 75 6d 63 70 75 73 20 32 29 29 0a 3b (/ numcpus 2)).;
8060: 3b 20 09 09 20 20 20 20 20 20 20 28 28 3e 20 6e ; .. ((> n
8070: 75 6d 63 70 75 73 20 34 29 28 2f 20 6e 75 6d 63 umcpus 4)(/ numc
8080: 70 75 73 20 31 2e 32 29 29 0a 3b 3b 20 09 09 20 pus 1.2)).;; ..
8090: 20 20 20 20 20 20 28 65 6c 73 65 20 30 2e 35 29 (else 0.5)
80a0: 29 29 0a 3b 3b 20 09 20 20 20 28 3e 20 63 6f 75 )).;; . (> cou
80b0: 6e 74 20 30 29 29 0a 3b 3b 20 20 20 20 20 20 20 nt 0)).;;
80c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
80d0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
80e0: 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 6e 67 20 -port* "waiting
80f0: 22 20 61 64 6a 77 61 69 74 20 22 20 73 65 63 6f " adjwait " seco
8100: 6e 64 73 20 64 75 65 20 74 6f 20 70 6f 73 73 69 nds due to possi
8110: 62 6c 65 20 6c 6f 61 64 20 6a 75 6d 70 20 22 20 ble load jump "
8120: 6c 6f 61 64 6a 6d 70 20 22 2e 20 22 0a 3b 3b 20 loadjmp ". ".;;
8130: 09 09 09 28 69 66 20 6d 73 67 20 6d 73 67 20 22 ...(if msg msg "
8140: 22 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 74 68 ")).;; (th
8150: 72 65 61 64 2d 73 6c 65 65 70 21 20 61 64 6a 77 read-sleep! adjw
8160: 61 69 74 29 0a 3b 3b 20 20 20 20 20 20 20 28 63 ait).;; (c
8170: 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 ommon:wait-for-c
8180: 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e puload maxload n
8190: 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 umcpus waitdelay
81a0: 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 count: (- count
81b0: 20 31 29 20 6d 73 67 3a 20 6d 73 67 20 72 65 6d 1) msg: msg rem
81c0: 6f 74 65 2d 68 6f 73 74 3a 20 72 65 6d 6f 74 65 ote-host: remote
81d0: 2d 68 6f 73 74 29 29 0a 3b 3b 20 20 20 20 20 20 -host)).;;
81e0: 28 65 6c 73 65 0a 3b 3b 20 20 20 20 20 20 20 28 (else.;; (
81f0: 69 66 20 28 3e 20 6e 75 6d 2d 74 72 69 65 73 20 if (> num-tries
8200: 30 29 0a 3b 3b 20 09 20 20 28 69 66 20 28 63 6f 0).;; . (if (co
8210: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
8220: 72 69 6e 74 20 33 30 20 28 63 6f 6e 63 20 28 72 rint 30 (conc (r
8230: 6f 75 6e 64 20 66 69 72 73 74 29 20 22 2d 6c 6f ound first) "-lo
8240: 61 64 2d 61 63 63 65 70 74 61 62 6c 65 2d 22 20 ad-acceptable-"
8250: 28 6f 72 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 (or remote-host
8260: 22 6c 6f 63 61 6c 68 6f 73 74 22 29 29 29 0a 3b "localhost"))).;
8270: 3b 20 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ; . (debug:
8280: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
8290: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4c 6f 61 64 -log-port* "Load
82a0: 20 6f 6e 20 22 20 28 6f 72 20 72 65 6d 6f 74 65 on " (or remote
82b0: 2d 68 6f 73 74 20 22 6c 6f 63 61 6c 68 6f 73 74 -host "localhost
82c0: 22 29 20 22 20 69 73 20 61 63 63 65 70 74 61 62 ") " is acceptab
82d0: 6c 65 20 61 74 20 22 20 66 69 72 73 74 20 22 20 le at " first "
82e0: 63 6f 6e 74 69 6e 75 69 6e 67 2e 22 29 29 0a 3b continuing.")).;
82f0: 3b 20 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ; . (debug:prin
8300: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
8310: 2d 70 6f 72 74 2a 20 22 4c 6f 61 64 20 6f 6e 20 -port* "Load on
8320: 22 20 28 6f 72 20 72 65 6d 6f 74 65 2d 68 6f 73 " (or remote-hos
8330: 74 20 22 6c 6f 63 61 6c 68 6f 73 74 22 29 20 22 t "localhost") "
8340: 2c 20 22 66 69 72 73 74 22 20 63 6f 75 6c 64 20 , "first" could
8350: 6e 6f 74 20 62 65 20 72 65 74 72 69 65 76 65 64 not be retrieved
8360: 2e 20 47 69 76 69 6e 67 20 75 70 20 61 6e 64 20 . Giving up and
8370: 63 6f 6e 74 69 6e 75 69 6e 67 2e 22 29 29 29 29 continuing."))))
8380: 29 29 0a 3b 3b 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d )).;; ..;;======
8390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83d0: 0a 3b 3b 20 77 61 69 74 20 66 6f 72 20 6e 6f 72 .;; wait for nor
83e0: 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f 61 64 malized cpu load
83f0: 20 74 6f 20 64 72 6f 70 20 62 65 6c 6f 77 20 6d to drop below m
8400: 61 78 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 6e axload.;;.(defin
8410: 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 e (common:wait-f
8420: 6f 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 6c 6f or-normalized-lo
8430: 61 64 20 6d 61 78 6e 6f 72 6d 6c 6f 61 64 20 6d ad maxnormload m
8440: 73 67 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 sg remote-host #
8450: 21 6f 70 74 69 6f 6e 61 6c 20 28 72 65 6d 2d 74 !optional (rem-t
8460: 72 69 65 73 20 35 29 29 0a 20 20 28 6c 65 74 20 ries 5)). (let
8470: 28 28 6e 75 6d 2d 63 70 75 73 20 28 63 6f 6d 6d ((num-cpus (comm
8480: 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 73 20 on:get-num-cpus
8490: 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 20 remote-host))).
84a0: 20 20 20 28 69 66 20 6e 75 6d 2d 63 70 75 73 0a (if num-cpus.
84b0: 09 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f .(common:wait-fo
84c0: 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6e 6f 72 r-cpuload maxnor
84d0: 6d 6c 6f 61 64 20 6e 75 6d 2d 63 70 75 73 20 31 mload num-cpus 1
84e0: 35 20 6d 73 67 3a 20 6d 73 67 20 72 65 6d 6f 74 5 msg: msg remot
84f0: 65 2d 68 6f 73 74 3a 20 72 65 6d 6f 74 65 2d 68 e-host: remote-h
8500: 6f 73 74 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 ost)..(begin..
8510: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
8520: 72 61 6e 64 6f 6d 20 36 30 29 29 20 3b 3b 20 77 random 60)) ;; w
8530: 65 20 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 e failed to get
8540: 6e 75 6d 20 63 70 75 73 2e 20 77 61 69 74 20 61 num cpus. wait a
8550: 20 62 69 74 20 61 6e 64 20 74 72 79 20 61 67 61 bit and try aga
8560: 69 6e 0a 09 20 20 28 69 66 20 28 3e 20 72 65 6d in.. (if (> rem
8570: 2d 74 72 69 65 73 20 30 29 0a 09 20 20 20 20 20 -tries 0)..
8580: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
8590: 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 6c 6f 61 r-normalized-loa
85a0: 64 20 6d 61 78 6e 6f 72 6d 6c 6f 61 64 20 6d 73 d maxnormload ms
85b0: 67 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 28 2d g remote-host (-
85c0: 20 72 65 6d 2d 74 72 69 65 73 20 31 29 29 0a 09 rem-tries 1))..
85d0: 20 20 20 20 20 20 23 66 29 29 29 29 29 0a 0a 0a #f)))))...
85e0: 29 0a ).