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 72 65 71 75 ses/>..;;..(requ
0300: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
0310: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
0320: 63 70 20 73 31 31 6e 29 0a 0a 28 75 73 65 20 73 cp s11n)..(use s
0330: 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 rfi-1 posix rege
0340: 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 x regex-case srf
0350: 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d 64 i-69 hostinfo md
0360: 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 5 message-digest
0370: 0a 20 20 20 20 20 64 69 72 65 63 74 6f 72 79 2d . directory-
0380: 75 74 69 6c 73 20 70 6f 73 69 78 2d 65 78 74 72 utils posix-extr
0390: 61 73 20 6d 61 74 63 68 61 62 6c 65 20 75 74 69 as matchable uti
03a0: 6c 73 29 0a 0a 28 75 73 65 20 73 70 69 66 66 79 ls)..(use spiffy
03b0: 20 75 72 69 2d 63 6f 6d 6d 6f 6e 20 69 6e 74 61 uri-common inta
03c0: 72 77 65 62 20 68 74 74 70 2d 63 6c 69 65 6e 74 rweb http-client
03d0: 20 73 70 69 66 66 79 2d 72 65 71 75 65 73 74 2d spiffy-request-
03e0: 76 61 72 73 29 0a 0a 28 64 65 63 6c 61 72 65 20 vars)..(declare
03f0: 28 75 6e 69 74 20 73 65 72 76 65 72 29 29 0a 0a (unit server))..
0400: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 (declare (uses c
0410: 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a 0a 28 64 65 63 ommonmod))..(dec
0420: 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f lare (uses commo
0430: 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 n)).(declare (us
0440: 65 73 20 64 62 29 29 0a 28 64 65 63 6c 61 72 65 es db)).(declare
0450: 20 28 75 73 65 73 20 74 61 73 6b 73 29 29 20 3b (uses tasks)) ;
0460: 3b 20 74 61 73 6b 73 20 61 72 65 20 77 68 65 72 ; tasks are wher
0470: 65 20 73 74 75 66 66 20 69 73 20 6d 61 69 6e 74 e stuff is maint
0480: 61 69 6e 65 64 20 61 62 6f 75 74 20 77 68 61 74 ained about what
0490: 20 69 73 20 72 75 6e 6e 69 6e 67 2e 0a 3b 3b 20 is running..;;
04a0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 (declare (uses s
04b0: 79 6e 63 68 61 73 68 29 29 0a 28 64 65 63 6c 61 ynchash)).(decla
04c0: 72 65 20 28 75 73 65 73 20 68 74 74 70 2d 74 72 re (uses http-tr
04d0: 61 6e 73 70 6f 72 74 29 29 0a 3b 3b 28 64 65 63 ansport)).;;(dec
04e0: 6c 61 72 65 20 28 75 73 65 73 20 72 70 63 2d 74 lare (uses rpc-t
04f0: 72 61 6e 73 70 6f 72 74 29 29 0a 28 64 65 63 6c ransport)).(decl
0500: 61 72 65 20 28 75 73 65 73 20 6c 61 75 6e 63 68 are (uses launch
0510: 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 )).;; (declare (
0520: 75 73 65 73 20 64 61 65 6d 6f 6e 29 29 0a 0a 28 uses daemon))..(
0530: 69 6d 70 6f 72 74 20 63 6f 6d 6d 6f 6e 6d 6f 64 import commonmod
0540: 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d )..(include "com
0550: 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 mon_records.scm"
0560: 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 ).(include "db_r
0570: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 64 ecords.scm")..(d
0580: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6d 61 efine (server:ma
0590: 6b 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 68 6f ke-server-url ho
05a0: 73 74 70 6f 72 74 29 0a 20 20 28 69 66 20 28 6e stport). (if (n
05b0: 6f 74 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 20 ot hostport).
05c0: 20 20 20 23 66 0a 20 20 20 20 20 20 28 63 6f 6e #f. (con
05d0: 63 20 22 68 74 74 70 3a 2f 2f 22 20 28 63 61 72 c "http://" (car
05e0: 20 68 6f 73 74 70 6f 72 74 29 20 22 3a 22 20 28 hostport) ":" (
05f0: 63 61 64 72 20 68 6f 73 74 70 6f 72 74 29 29 29 cadr hostport)))
0600: 29 0a 0a 28 64 65 66 69 6e 65 20 20 2a 73 65 72 )..(define *ser
0610: 76 65 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 2d 62 ver-loop-heart-b
0620: 65 61 74 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 eat* (current-se
0630: 63 6f 6e 64 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d conds))..;;=====
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: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0680: 3d 0a 3b 3b 20 50 20 4b 20 54 20 53 20 20 20 53 =.;; P K T S S
0690: 20 54 20 55 20 46 20 46 20 0a 3b 3b 3d 3d 3d 3d T U F F .;;====
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06e0: 3d 3d 0a 0a 3b 3b 20 3f 3f 3f 0a 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 0a 3b 3b 20 50 20 4b 20 54 20 53 20 ====.;; P K T S
0740: 20 20 53 20 54 20 55 20 46 20 46 20 0a 3b 3b 3d S T U F F .;;=
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 3f 3f 3f 0a 0a 3b =====..;; ???..;
07a0: 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07e0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 =======.;; S E R
07f0: 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d V E R.;;=======
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 3d 3d ================
0830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
0840: 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 74 6f .;; Call this to
0850: 20 73 74 61 72 74 20 74 68 65 20 61 63 74 75 61 start the actua
0860: 6c 20 73 65 72 76 65 72 0a 3b 3b 0a 0a 3b 3b 3d l server.;;..;;=
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08b0: 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 56 =====.;; S E R V
08c0: 20 45 20 52 20 20 20 55 20 54 20 49 20 4c 20 49 E R U T I L I
08d0: 20 54 20 49 20 45 20 53 20 0a 3b 3b 3d 3d 3d 3d T I E S .;;====
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0920: 3d 3d 0a 0a 3b 3b 20 47 65 74 20 74 68 65 20 74 ==..;; Get the t
0930: 72 61 6e 73 70 6f 72 74 0a 28 64 65 66 69 6e 65 ransport.(define
0940: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 74 72 61 (server:get-tra
0950: 6e 73 70 6f 72 74 29 0a 20 20 28 69 66 20 2a 74 nsport). (if *t
0960: 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 0a 20 ransport-type*.
0970: 20 20 20 20 20 2a 74 72 61 6e 73 70 6f 72 74 2d *transport-
0980: 74 79 70 65 2a 0a 20 20 20 20 20 20 28 6c 65 74 type*. (let
0990: 20 28 28 74 74 79 70 65 20 28 73 74 72 69 6e 67 ((ttype (string
09a0: 2d 3e 73 79 6d 62 6f 6c 0a 09 09 20 20 20 20 28 ->symbol... (
09b0: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
09c0: 20 22 2d 74 72 61 6e 73 70 6f 72 74 22 29 0a 09 "-transport")..
09d0: 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ..(configf:looku
09e0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
09f0: 65 72 76 65 72 22 20 22 74 72 61 6e 73 70 6f 72 erver" "transpor
0a00: 74 22 29 0a 09 09 09 22 72 70 63 22 29 29 29 29 t")...."rpc"))))
0a10: 0a 09 28 73 65 74 21 20 2a 74 72 61 6e 73 70 6f ..(set! *transpo
0a20: 72 74 2d 74 79 70 65 2a 20 74 74 79 70 65 29 0a rt-type* ttype).
0a30: 09 74 74 79 70 65 29 29 29 0a 09 20 20 20 20 0a .ttype))).. .
0a40: 3b 3b 20 47 65 6e 65 72 61 74 65 20 61 20 75 6e ;; Generate a un
0a50: 69 71 75 65 20 73 69 67 6e 61 74 75 72 65 20 66 ique signature f
0a60: 6f 72 20 74 68 69 73 20 73 65 72 76 65 72 0a 28 or this server.(
0a70: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6d define (server:m
0a80: 6b 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 k-signature). (
0a90: 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 message-digest-s
0aa0: 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 tring (md5-primi
0ab0: 74 69 76 65 29 20 0a 09 09 09 20 28 77 69 74 68 tive) .... (with
0ac0: 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e -output-to-strin
0ad0: 67 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 61 20 g.... (lambda
0ae0: 28 29 0a 09 09 09 20 20 20 20 20 28 77 72 69 74 ().... (writ
0af0: 65 20 28 6c 69 73 74 20 28 63 75 72 72 65 6e 74 e (list (current
0b00: 2d 64 69 72 65 63 74 6f 72 79 29 0a 20 20 20 20 -directory).
0b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b30: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 70 (current-p
0b40: 72 6f 63 65 73 73 2d 69 64 29 0a 09 09 09 09 09 rocess-id)......
0b50: 20 20 28 61 72 67 76 29 29 29 29 29 29 29 0a 0a (argv)))))))..
0b60: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
0b70: 67 65 74 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 get-client-signa
0b80: 74 75 72 65 29 0a 20 20 28 69 66 20 2a 6d 79 2d ture). (if *my-
0b90: 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 client-signature
0ba0: 2a 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 * *my-client-sig
0bb0: 6e 61 74 75 72 65 2a 0a 20 20 20 20 20 20 28 6c nature*. (l
0bc0: 65 74 20 28 28 73 69 67 20 28 73 65 72 76 65 72 et ((sig (server
0bd0: 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 29 29 :mk-signature)))
0be0: 20 3b 3b 20 63 6c 69 65 6e 74 73 20 72 65 2d 75 ;; clients re-u
0bf0: 73 65 20 74 68 65 20 73 65 72 76 65 72 3a 6d 6b se the server:mk
0c00: 2d 73 69 67 6e 61 74 75 72 65 20 6c 6f 67 69 63 -signature logic
0c10: 0a 20 20 20 20 20 20 20 20 28 73 65 74 21 20 2a . (set! *
0c20: 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 my-client-signat
0c30: 75 72 65 2a 20 73 69 67 29 0a 20 20 20 20 20 20 ure* sig).
0c40: 20 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 *my-client-sig
0c50: 6e 61 74 75 72 65 2a 29 29 29 0a 0a 28 64 65 66 nature*)))..(def
0c60: 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d ine (server:get-
0c70: 73 65 72 76 65 72 2d 69 64 29 0a 20 20 28 69 66 server-id). (if
0c80: 20 2a 73 65 72 76 65 72 2d 69 64 2a 20 2a 73 65 *server-id* *se
0c90: 72 76 65 72 2d 69 64 2a 0a 20 20 20 20 20 20 28 rver-id*. (
0ca0: 6c 65 74 20 28 28 73 69 67 20 28 73 65 72 76 65 let ((sig (serve
0cb0: 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 29 r:mk-signature))
0cc0: 29 20 3b 3b 20 63 6c 69 65 6e 74 73 20 72 65 2d ) ;; clients re-
0cd0: 75 73 65 20 74 68 65 20 73 65 72 76 65 72 3a 6d use the server:m
0ce0: 6b 2d 73 69 67 6e 61 74 75 72 65 20 6c 6f 67 69 k-signature logi
0cf0: 63 0a 20 20 20 20 20 20 20 20 28 73 65 74 21 20 c. (set!
0d00: 2a 73 65 72 76 65 72 2d 69 64 2a 20 73 69 67 29 *server-id* sig)
0d10: 0a 20 20 20 20 20 20 20 20 2a 73 65 72 76 65 72 . *server
0d20: 2d 69 64 2a 29 29 29 0a 0a 3b 3b 20 3b 3b 20 57 -id*)))..;; ;; W
0d30: 68 65 6e 20 75 73 69 6e 67 20 7a 6d 71 20 74 68 hen using zmq th
0d40: 69 73 20 77 6f 75 6c 64 20 73 65 6e 64 20 74 68 is would send th
0d50: 65 20 6d 65 73 73 61 67 65 20 62 61 63 6b 20 28 e message back (
0d60: 74 77 6f 20 73 74 65 70 20 70 72 6f 63 65 73 73 two step process
0d70: 29 0a 3b 3b 20 3b 3b 20 77 69 74 68 20 73 70 69 ).;; ;; with spi
0d80: 66 66 79 20 6f 72 20 72 70 63 20 74 68 69 73 20 ffy or rpc this
0d90: 73 69 6d 70 6c 79 20 72 65 74 75 72 6e 73 20 74 simply returns t
0da0: 68 65 20 72 65 74 75 72 6e 20 64 61 74 61 20 74 he return data t
0db0: 6f 20 62 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b o be returned.;;
0dc0: 20 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 ;; .;; (define
0dd0: 28 73 65 72 76 65 72 3a 72 65 70 6c 79 20 72 65 (server:reply re
0de0: 74 75 72 6e 2d 61 64 64 72 20 71 75 65 72 79 2d turn-addr query-
0df0: 73 69 67 20 73 75 63 63 65 73 73 2f 66 61 69 6c sig success/fail
0e00: 20 72 65 73 75 6c 74 29 0a 3b 3b 20 20 20 28 64 result).;; (d
0e10: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
0e20: 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 11 *default-log-
0e30: 70 6f 72 74 2a 20 22 73 65 72 76 65 72 3a 72 65 port* "server:re
0e40: 70 6c 79 20 72 65 74 75 72 6e 2d 61 64 64 72 3d ply return-addr=
0e50: 22 20 72 65 74 75 72 6e 2d 61 64 64 72 20 22 2c " return-addr ",
0e60: 20 72 65 73 75 6c 74 3d 22 20 72 65 73 75 6c 74 result=" result
0e70: 29 0a 3b 3b 20 20 20 3b 3b 20 28 73 65 6e 64 2d ).;; ;; (send-
0e80: 6d 65 73 73 61 67 65 20 70 75 62 73 6f 63 6b 20 message pubsock
0e90: 74 61 72 67 65 74 20 73 65 6e 64 2d 6d 6f 72 65 target send-more
0ea0: 3a 20 23 74 29 0a 3b 3b 20 20 20 3b 3b 20 28 73 : #t).;; ;; (s
0eb0: 65 6e 64 2d 6d 65 73 73 61 67 65 20 70 75 62 73 end-message pubs
0ec0: 6f 63 6b 20 0a 3b 3b 20 20 20 28 63 61 73 65 20 ock .;; (case
0ed0: 28 73 65 72 76 65 72 3a 67 65 74 2d 74 72 61 6e (server:get-tran
0ee0: 73 70 6f 72 74 29 0a 3b 3b 20 20 20 20 20 28 28 sport).;; ((
0ef0: 72 70 63 29 20 20 28 64 62 3a 6f 62 6a 2d 3e 73 rpc) (db:obj->s
0f00: 74 72 69 6e 67 20 28 76 65 63 74 6f 72 20 73 75 tring (vector su
0f10: 63 63 65 73 73 2f 66 61 69 6c 20 71 75 65 72 79 ccess/fail query
0f20: 2d 73 69 67 20 72 65 73 75 6c 74 29 29 29 0a 3b -sig result))).;
0f30: 3b 20 20 20 20 20 28 28 68 74 74 70 29 20 28 64 ; ((http) (d
0f40: 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 28 76 b:obj->string (v
0f50: 65 63 74 6f 72 20 73 75 63 63 65 73 73 2f 66 61 ector success/fa
0f60: 69 6c 20 71 75 65 72 79 2d 73 69 67 20 72 65 73 il query-sig res
0f70: 75 6c 74 29 29 29 0a 3b 3b 20 20 20 20 20 28 28 ult))).;; ((
0f80: 66 73 29 20 20 20 72 65 73 75 6c 74 29 0a 3b 3b fs) result).;;
0f90: 20 20 20 20 20 28 65 6c 73 65 20 0a 3b 3b 20 20 (else .;;
0fa0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0fb0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
0fc0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 75 6e 72 t-log-port* "unr
0fd0: 65 63 6f 67 6e 69 73 65 64 20 74 72 61 6e 73 70 ecognised transp
0fe0: 6f 72 74 20 74 79 70 65 3a 20 22 20 2a 74 72 61 ort type: " *tra
0ff0: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 29 0a 3b 3b nsport-type*).;;
1000: 20 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a result))).
1010: 0a 3b 3b 20 47 69 76 65 6e 20 61 6e 20 61 72 65 .;; Given an are
1020: 61 20 70 61 74 68 2c 20 20 73 74 61 72 74 20 61 a path, start a
1030: 20 73 65 72 76 65 72 20 70 72 6f 63 65 73 73 20 server process
1040: 20 20 20 23 23 23 20 4e 4f 54 45 20 23 23 23 20 ### NOTE ###
1050: 3e 20 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 > file 2>&1 .;;
1060: 69 66 20 74 68 65 20 74 61 72 67 65 74 2d 68 6f if the target-ho
1070: 73 74 20 69 73 20 73 65 74 20 0a 3b 3b 20 74 72 st is set .;; tr
1080: 79 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 68 61 y running on tha
1090: 74 20 68 6f 73 74 0a 3b 3b 20 20 20 69 6e 63 69 t host.;; inci
10a0: 64 65 6e 74 61 6c 3a 20 72 6f 74 61 74 65 20 6c dental: rotate l
10b0: 6f 67 73 20 69 6e 20 6c 6f 67 73 2f 20 64 69 72 ogs in logs/ dir
10c0: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 20 28 73 ..;;.(define (s
10d0: 65 72 76 65 72 3a 72 75 6e 20 61 72 65 61 70 61 erver:run areapa
10e0: 74 68 29 20 3b 3b 20 61 72 65 61 70 61 74 68 20 th) ;; areapath
10f0: 69 73 20 2a 74 6f 70 70 61 74 68 2a 20 66 6f 72 is *toppath* for
1100: 20 61 20 67 69 76 65 6e 20 74 65 73 74 73 75 69 a given testsui
1110: 74 65 20 61 72 65 61 0a 20 20 28 6c 65 74 2a 20 te area. (let*
1120: 28 28 74 65 73 74 73 75 69 74 65 20 20 20 28 63 ((testsuite (c
1130: 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 ommon:get-testsu
1140: 69 74 65 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f ite-name)).. (lo
1150: 67 66 69 6c 65 20 20 20 20 20 28 63 6f 6e 63 20 gfile (conc
1160: 61 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 2f areapath "/logs/
1170: 73 65 72 76 65 72 2e 6c 6f 67 22 29 29 20 3b 3b server.log")) ;;
1180: 20 2d 22 20 63 75 72 72 2d 70 69 64 20 22 2d 22 -" curr-pid "-"
1190: 20 74 61 72 67 65 74 2d 68 6f 73 74 20 22 2e 6c target-host ".l
11a0: 6f 67 22 29 29 0a 09 20 28 70 72 6f 66 69 6c 65 og")).. (profile
11b0: 2d 6d 6f 64 65 20 28 6f 72 20 28 63 6f 6e 66 69 -mode (or (confi
11c0: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
11d0: 67 64 61 74 2a 20 22 6d 69 73 63 22 20 22 70 72 gdat* "misc" "pr
11e0: 6f 66 69 6c 65 73 77 22 29 0a 09 09 09 20 20 20 ofilesw")....
11f0: 22 22 29 29 0a 09 20 28 63 6d 64 6c 6e 20 28 63 "")).. (cmdln (c
1200: 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d onc (common:get-
1210: 6d 65 67 61 74 65 73 74 2d 65 78 65 29 0a 09 09 megatest-exe)...
1220: 20 20 20 20 20 20 22 20 2d 73 65 72 76 65 72 20 " -server
1230: 2d 20 22 3b 3b 20 28 6f 72 20 74 61 72 67 65 74 - ";; (or target
1240: 2d 68 6f 73 74 20 22 2d 22 29 0a 09 09 20 20 20 -host "-")...
1250: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 (if (equal? (
1260: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
1270: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 configdat* "serv
1280: 65 72 22 20 22 64 61 65 6d 6f 6e 69 7a 65 22 29 er" "daemonize")
1290: 20 22 79 65 73 22 29 0a 09 09 09 20 20 22 20 2d "yes").... " -
12a0: 64 61 65 6d 6f 6e 69 7a 65 20 22 0a 09 09 09 20 daemonize "....
12b0: 20 22 22 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 "")... ;;
12c0: 22 20 2d 6c 6f 67 20 22 20 6c 6f 67 66 69 6c 65 " -log " logfile
12d0: 0a 09 09 20 20 20 20 20 20 22 20 2d 6d 20 74 65 ... " -m te
12e0: 73 74 73 75 69 74 65 3a 22 20 74 65 73 74 73 75 stsuite:" testsu
12f0: 69 74 65 0a 09 09 20 20 20 20 20 20 22 20 22 20 ite... " "
1300: 70 72 6f 66 69 6c 65 2d 6d 6f 64 65 0a 09 09 20 profile-mode...
1310: 20 20 20 20 20 29 29 20 3b 3b 20 28 63 6f 6e 63 )) ;; (conc
1320: 20 22 20 3e 3e 20 22 20 6c 6f 67 66 69 6c 65 20 " >> " logfile
1330: 22 20 32 3e 26 31 20 26 22 29 29 29 29 29 0a 09 " 2>&1 &")))))..
1340: 20 28 6c 6f 67 2d 72 6f 74 61 74 65 20 20 28 6d (log-rotate (m
1350: 61 6b 65 2d 74 68 72 65 61 64 20 63 6f 6d 6d 6f ake-thread commo
1360: 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 20 20 22 n:rotate-logs "
1370: 73 65 72 76 65 72 20 72 75 6e 2c 20 72 6f 74 61 server run, rota
1380: 74 65 20 6c 6f 67 73 20 74 68 72 65 61 64 22 29 te logs thread")
1390: 29 20 3b 3b 20 77 68 79 20 61 72 65 20 77 65 20 ) ;; why are we
13a0: 72 6f 74 61 74 69 6e 67 20 6c 6f 67 73 20 68 65 rotating logs he
13b0: 72 65 3f 20 54 68 69 73 20 69 73 20 61 20 73 65 re? This is a se
13c0: 6e 73 69 74 69 76 65 20 6c 6f 63 61 74 69 6f 6e nsitive location
13d0: 20 77 69 74 68 20 61 20 6c 6f 74 20 67 6f 69 6e with a lot goin
13e0: 67 20 6f 6e 21 3f 0a 20 20 20 20 20 20 20 20 20 g on!?.
13f0: 28 6c 6f 61 64 2d 6c 69 6d 69 74 20 20 28 63 6f (load-limit (co
1400: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d nfigf:lookup-num
1410: 62 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 ber *configdat*
1420: 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 6d 61 78 2d "jobtools" "max-
1430: 73 65 72 76 65 72 2d 73 74 61 72 74 2d 6c 6f 61 server-start-loa
1440: 64 22 20 64 65 66 61 75 6c 74 3a 20 33 2e 30 29 d" default: 3.0)
1450: 29 29 0a 20 20 20 20 3b 3b 20 77 65 20 77 61 6e )). ;; we wan
1460: 74 20 74 68 65 20 72 65 6d 6f 74 65 20 73 65 72 t the remote ser
1470: 76 65 72 20 74 6f 20 73 74 61 72 74 20 69 6e 20 ver to start in
1480: 2a 74 6f 70 70 61 74 68 2a 20 73 6f 20 70 75 73 *toppath* so pus
1490: 68 20 74 68 65 72 65 0a 20 20 20 20 28 70 75 73 h there. (pus
14a0: 68 2d 64 69 72 65 63 74 6f 72 79 20 61 72 65 61 h-directory area
14b0: 70 61 74 68 29 0a 20 20 20 20 28 64 65 62 75 67 path). (debug
14c0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
14d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
14e0: 4f 3a 20 54 72 79 69 6e 67 20 74 6f 20 73 74 61 O: Trying to sta
14f0: 72 74 20 73 65 72 76 65 72 20 28 22 20 63 6d 64 rt server (" cmd
1500: 6c 6e 20 22 29 20 2e 2e 2e 22 29 0a 20 20 20 20 ln ") ...").
1510: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 6c (thread-start! l
1520: 6f 67 2d 72 6f 74 61 74 65 29 0a 20 20 20 20 0a og-rotate). .
1530: 20 20 20 20 3b 3b 20 68 6f 73 74 2e 64 6f 6d 61 ;; host.doma
1540: 69 6e 2e 74 6c 64 20 6d 61 74 63 68 20 68 6f 73 in.tld match hos
1550: 74 3f 0a 20 20 20 20 3b 3b 20 28 69 66 20 28 61 t?. ;; (if (a
1560: 6e 64 20 74 61 72 67 65 74 2d 68 6f 73 74 20 0a nd target-host .
1570: 20 20 20 20 3b 3b 20 09 20 20 20 20 20 3b 3b 20 ;; . ;;
1580: 6c 6f 6f 6b 20 61 74 20 74 61 72 67 65 74 20 68 look at target h
1590: 6f 73 74 2c 20 69 73 20 69 74 20 68 6f 73 74 2e ost, is it host.
15a0: 64 6f 6d 61 69 6e 2e 74 6c 64 20 6f 72 20 69 70 domain.tld or ip
15b0: 20 61 64 64 72 65 73 73 20 61 6e 64 20 64 6f 65 address and doe
15c0: 73 20 69 74 20 0a 20 20 20 20 3b 3b 20 09 20 20 s it . ;; .
15d0: 20 20 20 3b 3b 20 6d 61 74 63 68 20 63 75 72 72 ;; match curr
15e0: 65 6e 74 20 69 70 20 6f 72 20 68 6f 73 74 6e 61 ent ip or hostna
15f0: 6d 65 0a 20 20 20 20 3b 3b 20 09 20 20 20 20 20 me. ;; .
1600: 28 6e 6f 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 (not (string-mat
1610: 63 68 20 28 63 6f 6e 63 20 22 28 22 63 75 72 72 ch (conc "("curr
1620: 2d 68 6f 73 74 20 22 7c 22 20 63 75 72 72 2d 68 -host "|" curr-h
1630: 6f 73 74 22 5c 5c 2e 2e 2a 29 22 29 20 74 61 72 ost"\\..*)") tar
1640: 67 65 74 2d 68 6f 73 74 29 29 0a 20 20 20 20 3b get-host)). ;
1650: 3b 20 09 20 20 20 20 20 28 6e 6f 74 20 28 65 71 ; . (not (eq
1660: 75 61 6c 3f 20 63 75 72 72 2d 69 70 20 74 61 72 ual? curr-ip tar
1670: 67 65 74 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 get-host))).
1680: 3b 3b 20 09 28 62 65 67 69 6e 0a 20 20 20 20 3b ;; .(begin. ;
1690: 3b 20 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ; . (debug:prin
16a0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
16b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 t-log-port* "Sta
16c0: 72 74 69 6e 67 20 73 65 72 76 65 72 20 6f 6e 20 rting server on
16d0: 22 20 74 61 72 67 65 74 2d 68 6f 73 74 20 22 2c " target-host ",
16e0: 20 6c 6f 67 66 69 6c 65 20 69 73 20 22 20 6c 6f logfile is " lo
16f0: 67 66 69 6c 65 29 0a 20 20 20 20 3b 3b 20 09 20 gfile). ;; .
1700: 20 28 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 (setenv "TARGET
1710: 48 4f 53 54 22 20 74 61 72 67 65 74 2d 68 6f 73 HOST" target-hos
1720: 74 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 0a 20 t))). ;; .
1730: 20 20 20 28 73 65 74 65 6e 76 20 22 54 41 52 47 (setenv "TARG
1740: 45 54 48 4f 53 54 5f 4c 4f 47 46 22 20 6c 6f 67 ETHOST_LOGF" log
1750: 66 69 6c 65 29 0a 20 20 20 20 28 74 68 72 65 61 file). (threa
1760: 64 2d 73 6c 65 65 70 21 20 28 2f 20 28 72 61 6e d-sleep! (/ (ran
1770: 64 6f 6d 20 33 30 30 30 29 20 31 30 30 30 29 29 dom 3000) 1000))
1780: 20 3b 3b 20 61 64 64 20 61 20 72 61 6e 64 6f 6d ;; add a random
1790: 20 69 6e 69 74 69 61 6c 20 64 65 6c 61 79 2e 20 initial delay.
17a0: 49 74 20 73 65 65 6d 73 20 70 72 65 74 74 79 20 It seems pretty
17b0: 63 6f 6d 6d 6f 6e 20 74 68 61 74 20 6d 61 6e 79 common that many
17c0: 20 72 75 6e 6e 69 6e 67 20 74 65 73 74 73 20 72 running tests r
17d0: 65 71 75 65 73 74 20 61 20 73 65 72 76 65 72 20 equest a server
17e0: 61 74 20 74 68 65 20 73 61 6d 65 20 74 69 6d 65 at the same time
17f0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
1800: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
1810: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 73 74 -port* "INFO: st
1820: 61 72 74 69 6e 67 20 73 65 72 76 65 72 20 61 74 arting server at
1830: 20 22 20 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e " (common:human
1840: 2d 74 69 6d 65 29 29 0a 20 20 20 20 28 73 79 73 -time)). (sys
1850: 74 65 6d 20 28 63 6f 6e 63 20 22 6e 62 66 61 6b tem (conc "nbfak
1860: 65 20 22 20 63 6d 64 6c 6e 29 29 0a 20 20 20 20 e " cmdln)).
1870: 28 75 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 (unsetenv "TARGE
1880: 54 48 4f 53 54 5f 4c 4f 47 46 22 29 0a 20 20 20 THOST_LOGF").
1890: 20 3b 3b 20 28 69 66 20 28 67 65 74 2d 65 6e 76 ;; (if (get-env
18a0: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
18b0: 65 20 22 54 41 52 47 45 54 48 4f 53 54 22 29 28 e "TARGETHOST")(
18c0: 75 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 unsetenv "TARGET
18d0: 48 4f 53 54 22 29 29 0a 20 20 20 20 28 74 68 72 HOST")). (thr
18e0: 65 61 64 2d 6a 6f 69 6e 21 20 6c 6f 67 2d 72 6f ead-join! log-ro
18f0: 74 61 74 65 29 0a 20 20 20 20 28 70 6f 70 2d 64 tate). (pop-d
1900: 69 72 65 63 74 6f 72 79 29 29 29 0a 0a 3b 3b 20 irectory)))..;;
1910: 67 69 76 65 6e 20 61 20 70 61 74 68 20 74 6f 20 given a path to
1920: 61 20 73 65 72 76 65 72 20 6c 6f 67 20 72 65 74 a server log ret
1930: 75 72 6e 3a 20 68 6f 73 74 20 70 6f 72 74 20 73 urn: host port s
1940: 74 61 72 74 73 65 63 6f 6e 64 73 20 73 65 72 76 tartseconds serv
1950: 65 72 2d 69 64 0a 3b 3b 20 61 6e 79 20 63 68 61 er-id.;; any cha
1960: 6e 67 65 73 20 74 6f 20 6e 75 6d 62 65 72 20 6f nges to number o
1970: 66 20 65 6c 65 6d 65 6e 74 73 20 72 65 74 75 72 f elements retur
1980: 6e 65 64 20 62 79 20 74 68 69 73 20 66 75 63 74 ned by this fuct
1990: 69 6f 6e 20 77 69 6c 6c 20 64 69 72 63 74 6c 79 ion will dirctly
19a0: 20 61 66 66 65 63 74 20 73 65 72 76 65 72 3a 72 affect server:r
19b0: 65 63 6f 72 64 2d 3e 75 72 6c 2c 73 65 72 76 65 ecord->url,serve
19c0: 72 3a 72 65 63 6f 72 64 2d 3e 69 64 2c 73 65 72 r:record->id,ser
19d0: 76 65 72 3a 6b 69 6c 6c 2c 73 65 72 76 65 72 3a ver:kill,server:
19e0: 67 65 74 2d 6e 75 6d 2d 61 6c 69 76 65 20 77 68 get-num-alive wh
19f0: 69 63 68 20 75 73 65 20 6d 61 74 63 68 20 6c 65 ich use match le
1a00: 74 20 0a 3b 3b 20 65 78 61 6d 70 6c 65 20 6f 66 t .;; example of
1a10: 20 77 68 61 74 20 69 74 27 73 20 6c 6f 6f 6b 69 what it's looki
1a20: 6e 67 20 66 6f 72 20 69 6e 20 74 68 65 20 6c 6f ng for in the lo
1a30: 67 20 66 69 6c 65 3a 0a 3b 3b 20 20 20 20 20 53 g file:.;; S
1a40: 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 31 ERVER STARTED: 1
1a50: 30 2e 33 38 2e 31 37 35 2e 36 37 3a 35 30 32 31 0.38.175.67:5021
1a60: 36 20 41 54 20 31 36 31 36 35 30 32 33 35 30 2e 6 AT 1616502350.
1a70: 30 20 73 65 72 76 65 72 2d 69 64 3a 20 34 39 30 0 server-id: 490
1a80: 37 65 39 30 66 63 35 35 63 37 61 30 39 36 39 34 7e90fc55c7a09694
1a90: 65 33 66 36 35 38 63 36 33 39 63 66 34 20 0a 0a e3f658c639cf4 ..
1aa0: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
1ab0: 6c 6f 67 66 2d 67 65 74 2d 73 74 61 72 74 2d 69 logf-get-start-i
1ac0: 6e 66 6f 20 6c 6f 67 66 29 0a 20 20 28 6c 65 74 nfo logf). (let
1ad0: 20 28 28 73 65 72 76 65 72 2d 72 78 20 20 20 20 ((server-rx
1ae0: 28 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 52 (regexp "^SERVER
1af0: 20 53 54 41 52 54 45 44 3a 20 28 5c 5c 53 2b 29 STARTED: (\\S+)
1b00: 3a 28 5c 5c 64 2b 29 20 41 54 20 28 5b 5c 5c 64 :(\\d+) AT ([\\d
1b10: 5c 5c 2e 5d 2b 29 20 73 65 72 76 65 72 2d 69 64 \\.]+) server-id
1b20: 3a 20 28 5c 5c 53 2b 29 20 70 69 64 3a 20 28 5c : (\\S+) pid: (\
1b30: 5c 64 2b 29 22 29 29 20 3b 3b 20 53 45 52 56 45 \d+)")) ;; SERVE
1b40: 52 20 53 54 41 52 54 45 44 3a 20 68 6f 73 74 3a R STARTED: host:
1b50: 70 6f 72 74 20 41 54 20 74 69 6d 65 73 65 63 73 port AT timesecs
1b60: 20 73 65 72 76 65 72 20 69 64 0a 20 20 20 20 20 server id.
1b70: 20 20 20 28 64 62 70 72 65 70 2d 72 78 20 20 20 (dbprep-rx
1b80: 20 28 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 (regexp "^SERVE
1b90: 52 3a 20 64 62 70 72 65 70 22 29 29 0a 20 20 20 R: dbprep")).
1ba0: 20 20 20 20 20 28 64 62 70 72 65 70 2d 66 6f 75 (dbprep-fou
1bb0: 6e 64 20 30 29 0a 09 28 62 61 64 2d 64 61 74 20 nd 0)..(bad-dat
1bc0: 20 20 20 20 20 28 6c 69 73 74 20 23 66 20 23 66 (list #f #f
1bd0: 20 23 66 20 23 66 20 23 66 29 29 29 0a 20 20 20 #f #f #f))).
1be0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
1bf0: 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 ons. exn.
1c00: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
1c10: 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 74 68 69 73 ;; WARNING: this
1c20: 20 69 73 20 70 6f 74 65 6e 74 69 61 6c 6c 79 20 is potentially
1c30: 64 61 6e 67 65 72 6f 75 73 20 74 6f 20 62 6c 61 dangerous to bla
1c40: 6e 6b 65 74 20 69 67 6e 6f 72 65 20 74 68 65 20 nket ignore the
1c50: 65 72 72 6f 72 73 0a 20 20 20 20 20 20 20 28 69 errors. (i
1c60: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
1c70: 6c 6f 67 66 29 0a 09 20 20 20 28 64 65 62 75 67 logf).. (debug
1c80: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 :print-info 2 *d
1c90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1ca0: 20 22 55 6e 61 62 6c 65 20 74 6f 20 67 65 74 20 "Unable to get
1cb0: 73 65 72 76 65 72 20 69 6e 66 6f 20 66 72 6f 6d server info from
1cc0: 20 22 6c 6f 67 66 22 2c 20 65 78 6e 3d 22 20 65 "logf", exn=" e
1cd0: 78 6e 29 29 0a 20 20 20 20 20 20 20 62 61 64 2d xn)). bad-
1ce0: 64 61 74 29 20 3b 3b 20 6e 6f 20 69 64 65 61 20 dat) ;; no idea
1cf0: 77 68 61 74 20 77 65 6e 74 20 77 72 6f 6e 67 2c what went wrong,
1d00: 20 63 61 6c 6c 20 69 74 20 61 20 62 61 64 20 73 call it a bad s
1d10: 65 72 76 65 72 0a 20 20 20 20 20 28 77 69 74 68 erver. (with
1d20: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 -input-from-file
1d30: 0a 09 20 6c 6f 67 66 0a 20 20 20 20 20 20 20 28 .. logf. (
1d40: 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 6c 65 74 lambda ().. (let
1d50: 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 20 28 72 65 loop ((inl (re
1d60: 61 64 2d 6c 69 6e 65 29 29 0a 09 09 20 20 20 20 ad-line))...
1d70: 28 6c 6e 75 6d 20 30 29 29 0a 09 20 20 20 28 69 (lnum 0)).. (i
1d80: 66 20 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 f (not (eof-obje
1d90: 63 74 3f 20 69 6e 6c 29 29 0a 09 20 20 20 20 20 ct? inl))..
1da0: 20 20 28 6c 65 74 20 28 28 6d 6c 73 74 20 28 73 (let ((mlst (s
1db0: 74 72 69 6e 67 2d 6d 61 74 63 68 20 73 65 72 76 tring-match serv
1dc0: 65 72 2d 72 78 20 69 6e 6c 29 29 0a 09 09 20 20 er-rx inl))...
1dd0: 20 20 20 28 64 62 70 72 65 70 20 28 73 74 72 69 (dbprep (stri
1de0: 6e 67 2d 6d 61 74 63 68 20 64 62 70 72 65 70 2d ng-match dbprep-
1df0: 72 78 20 69 6e 6c 29 29 29 0a 09 09 20 28 69 66 rx inl)))... (if
1e00: 20 64 62 70 72 65 70 20 28 73 65 74 21 20 64 62 dbprep (set! db
1e10: 70 72 65 70 2d 66 6f 75 6e 64 20 31 29 29 0a 09 prep-found 1))..
1e20: 09 20 28 69 66 20 28 6e 6f 74 20 6d 6c 73 74 29 . (if (not mlst)
1e30: 0a 09 09 20 20 20 20 20 28 69 66 20 28 3c 20 6c ... (if (< l
1e40: 6e 75 6d 20 35 30 30 29 20 3b 3b 20 67 69 76 65 num 500) ;; give
1e50: 20 75 70 20 69 66 20 6d 6f 72 65 20 74 68 61 6e up if more than
1e60: 20 35 30 30 20 6c 69 6e 65 73 20 6f 66 20 73 65 500 lines of se
1e70: 72 76 65 72 20 6c 6f 67 20 72 65 61 64 0a 09 09 rver log read...
1e80: 09 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 . (loop (read-li
1e90: 6e 65 29 28 2b 20 6c 6e 75 6d 20 31 29 29 0a 09 ne)(+ lnum 1))..
1ea0: 09 09 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 .. (begin .
1eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ec0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1ed0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
1ee0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e lt-log-port* "Un
1ef0: 61 62 6c 65 20 74 6f 20 67 65 74 20 73 65 72 76 able to get serv
1f00: 65 72 20 69 6e 66 6f 20 66 72 6f 6d 20 66 69 72 er info from fir
1f10: 73 74 20 35 30 30 20 6c 69 6e 65 73 20 6f 66 20 st 500 lines of
1f20: 22 20 6c 6f 67 66 20 29 0a 20 20 20 20 20 20 20 " logf ).
1f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f40: 20 20 20 20 62 61 64 2d 64 61 74 29 29 0a 09 09 bad-dat))...
1f50: 20 20 20 20 20 28 6d 61 74 63 68 20 6d 6c 73 74 (match mlst
1f60: 0a 09 09 09 20 20 20 20 28 28 5f 20 68 6f 73 74 .... ((_ host
1f70: 20 70 6f 72 74 20 73 74 61 72 74 20 73 65 72 76 port start serv
1f80: 65 72 2d 69 64 20 70 69 64 29 0a 09 09 09 20 20 er-id pid)....
1f90: 20 20 20 28 6c 69 73 74 20 68 6f 73 74 0a 09 09 (list host...
1fa0: 09 09 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 .. (string->nu
1fb0: 6d 62 65 72 20 70 6f 72 74 29 0a 09 09 09 09 20 mber port).....
1fc0: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
1fd0: 72 20 73 74 61 72 74 29 0a 09 09 09 09 20 20 20 r start).....
1fe0: 73 65 72 76 65 72 2d 69 64 0a 09 09 09 09 20 20 server-id.....
1ff0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
2000: 20 70 69 64 29 29 29 0a 09 09 09 20 20 20 20 28 pid))).... (
2010: 65 6c 73 65 0a 09 09 09 20 20 20 20 20 28 64 65 else.... (de
2020: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 63 75 72 bug:print 0 *cur
2030: 72 65 6e 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 rent-log-port* "
2040: 45 52 52 4f 52 3a 20 64 69 64 20 6e 6f 74 20 72 ERROR: did not r
2050: 65 63 6f 67 6e 69 73 65 20 53 45 52 56 45 52 20 ecognise SERVER
2060: 6c 69 6e 65 20 69 6e 66 6f 20 22 6d 6c 73 74 29 line info "mlst)
2070: 0a 09 09 09 20 20 20 20 20 62 61 64 2d 64 61 74 .... bad-dat
2080: 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 )))).. (be
2090: 67 69 6e 20 0a 09 09 20 28 69 66 20 64 62 70 72 gin ... (if dbpr
20a0: 65 70 2d 66 6f 75 6e 64 0a 09 09 20 20 20 20 20 ep-found...
20b0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 (begin...
20c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
20d0: 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 2 *default-log
20e0: 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 69 -port* "Server i
20f0: 73 20 69 6e 20 64 62 70 72 65 70 20 61 74 20 22 s in dbprep at "
2100: 20 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 (common:human-t
2110: 69 6d 65 29 29 0a 09 09 20 20 20 20 20 20 20 28 ime))... (
2120: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
2130: 35 29 29 20 3b 3b 20 77 61 73 20 32 35 20 73 65 5)) ;; was 25 se
2140: 63 20 62 75 74 20 74 68 61 74 20 62 6c 6f 63 6b c but that block
2150: 65 64 20 74 68 69 6e 67 73 20 66 72 6f 6d 20 73 ed things from s
2160: 74 61 72 74 69 6e 67 3f 0a 09 09 20 20 20 20 20 tarting?...
2170: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2180: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
2190: 2d 70 6f 72 74 2a 20 22 55 6e 61 62 6c 65 20 74 -port* "Unable t
21a0: 6f 20 67 65 74 20 73 65 72 76 65 72 20 69 6e 66 o get server inf
21b0: 6f 20 66 72 6f 6d 20 22 20 6c 6f 67 66 20 22 20 o from " logf "
21c0: 61 74 20 22 20 28 73 65 63 6f 6e 64 73 2d 3e 74 at " (seconds->t
21d0: 69 6d 65 2d 73 74 72 69 6e 67 20 28 63 75 72 72 ime-string (curr
21e0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a ent-seconds)))).
21f0: 09 09 20 62 61 64 2d 64 61 74 29 29 29 29 29 29 .. bad-dat))))))
2200: 29 29 0a 0a 3b 3b 20 3b 3b 20 67 65 74 20 61 20 ))..;; ;; get a
2210: 6c 69 73 74 20 6f 66 20 73 65 72 76 65 72 73 20 list of servers
2220: 66 72 6f 6d 20 74 68 65 20 6c 6f 67 20 66 69 6c from the log fil
2230: 65 73 2c 20 77 69 74 68 20 61 6c 6c 20 72 65 6c es, with all rel
2240: 65 76 61 6e 74 20 64 61 74 61 0a 3b 3b 20 3b 3b evant data.;; ;;
2250: 20 28 20 6d 6f 64 2d 74 69 6d 65 20 68 6f 73 74 ( mod-time host
2260: 20 70 6f 72 74 20 73 74 61 72 74 2d 74 69 6d 65 port start-time
2270: 20 70 69 64 20 29 0a 3b 3b 20 3b 3b 0a 3b 3b 20 pid ).;; ;;.;;
2280: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
2290: 67 65 74 2d 6c 69 73 74 20 61 72 65 61 70 61 74 get-list areapat
22a0: 68 20 23 21 6b 65 79 20 28 6c 69 6d 69 74 20 23 h #!key (limit #
22b0: 66 29 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 f)).;; (let ((
22c0: 66 6e 61 6d 65 2d 72 78 20 20 20 20 28 72 65 67 fname-rx (reg
22d0: 65 78 70 20 22 5e 28 7c 2e 2a 2f 29 73 65 72 76 exp "^(|.*/)serv
22e0: 65 72 2d 28 5c 5c 64 2b 29 2d 28 5c 5c 53 2b 29 er-(\\d+)-(\\S+)
22f0: 2e 6c 6f 67 24 22 29 29 0a 3b 3b 20 09 28 64 61 .log$")).;; .(da
2300: 79 2d 73 65 63 6f 6e 64 73 20 28 2a 20 32 34 20 y-seconds (* 24
2310: 36 30 20 36 30 29 29 29 0a 3b 3b 20 20 20 20 20 60 60))).;;
2320: 3b 3b 20 69 66 20 74 68 65 20 64 69 72 65 63 74 ;; if the direct
2330: 6f 72 79 20 65 78 69 73 74 73 20 63 6f 6e 74 69 ory exists conti
2340: 6e 75 65 20 74 6f 20 67 65 74 20 74 68 65 20 6c nue to get the l
2350: 69 73 74 0a 3b 3b 20 20 20 20 20 3b 3b 20 6f 74 ist.;; ;; ot
2360: 68 65 72 77 69 73 65 20 61 74 74 65 6d 70 74 20 herwise attempt
2370: 74 6f 20 63 72 65 61 74 65 20 74 68 65 20 6c 6f to create the lo
2380: 67 73 20 64 69 72 20 61 6e 64 20 74 68 65 6e 0a gs dir and then.
2390: 3b 3b 20 20 20 20 20 3b 3b 20 63 6f 6e 74 69 6e ;; ;; contin
23a0: 75 65 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 69 ue.;; (if (i
23b0: 66 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 f (directory-exi
23c0: 73 74 73 3f 20 28 63 6f 6e 63 20 61 72 65 61 70 sts? (conc areap
23d0: 61 74 68 20 22 2f 6c 6f 67 73 22 29 29 0a 3b 3b ath "/logs")).;;
23e0: 20 09 20 20 20 20 27 28 29 0a 3b 3b 20 09 20 20 . '().;; .
23f0: 20 20 28 69 66 20 28 66 69 6c 65 2d 77 72 69 74 (if (file-writ
2400: 65 2d 61 63 63 65 73 73 3f 20 61 72 65 61 70 61 e-access? areapa
2410: 74 68 29 0a 3b 3b 20 09 09 28 62 65 67 69 6e 0a th).;; ..(begin.
2420: 3b 3b 20 09 09 20 20 28 63 6f 6e 64 69 74 69 6f ;; .. (conditio
2430: 6e 2d 63 61 73 65 0a 3b 3b 20 09 09 20 20 20 28 n-case.;; .. (
2440: 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 create-directory
2450: 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 (conc areapath
2460: 22 2f 6c 6f 67 73 22 29 20 23 74 29 0a 3b 3b 20 "/logs") #t).;;
2470: 09 09 20 20 20 28 65 78 6e 20 28 69 2f 6f 20 66 .. (exn (i/o f
2480: 69 6c 65 29 28 64 65 62 75 67 3a 70 72 69 6e 74 ile)(debug:print
2490: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
24a0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 43 61 port* "ERROR: Ca
24b0: 6e 6e 6f 74 20 63 72 65 61 74 65 20 64 69 72 65 nnot create dire
24c0: 63 74 6f 72 79 20 61 74 20 22 20 28 63 6f 6e 63 ctory at " (conc
24d0: 20 61 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 areapath "/logs
24e0: 22 29 29 29 0a 3b 3b 20 09 09 20 20 20 28 65 78 "))).;; .. (ex
24f0: 6e 20 28 29 28 64 65 62 75 67 3a 70 72 69 6e 74 n ()(debug:print
2500: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2510: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 55 6e port* "ERROR: Un
2520: 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 61 74 74 65 known error atte
2530: 6d 74 70 69 6e 67 20 74 6f 20 67 65 74 20 73 65 mtping to get se
2540: 72 76 65 72 20 6c 69 73 74 2e 20 65 78 6e 3d 22 rver list. exn="
2550: 20 65 78 6e 29 29 29 0a 3b 3b 20 09 09 20 20 28 exn))).;; .. (
2560: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
2570: 3f 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 ? (conc areapath
2580: 20 22 2f 6c 6f 67 73 22 29 29 29 0a 3b 3b 20 09 "/logs"))).;; .
2590: 09 27 28 29 29 29 0a 3b 3b 20 0a 3b 3b 20 20 20 .'())).;; .;;
25a0: 20 20 20 20 20 20 3b 3b 20 47 65 74 20 74 68 65 ;; Get the
25b0: 20 6c 69 73 74 20 6f 66 20 73 65 72 76 65 72 20 list of server
25c0: 6c 6f 67 73 2e 0a 3b 3b 20 09 28 6c 65 74 2a 20 logs..;; .(let*
25d0: 28 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 (.;;
25e0: 20 20 20 20 3b 3b 20 46 6f 72 20 73 6f 6d 65 20 ;; For some
25f0: 72 65 61 73 6f 6e 2c 20 77 68 65 6e 20 49 20 75 reason, when I u
2600: 6e 63 6f 6d 6d 65 6e 74 20 74 68 65 20 62 65 6c ncomment the bel
2610: 6f 77 20 6c 69 6e 65 2c 20 65 78 74 2d 74 65 73 ow line, ext-tes
2620: 74 73 20 73 6f 6d 65 74 69 6d 65 73 20 73 74 61 ts sometimes sta
2630: 72 74 73 20 31 30 30 30 27 73 20 6f 66 20 73 65 rts 1000's of se
2640: 72 76 65 72 73 2e 0a 3b 3b 20 20 20 20 20 20 20 rvers..;;
2650: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 65 78 69 ;; (exi
2660: 74 69 6e 67 2d 73 65 72 76 65 72 73 20 28 73 79 ting-servers (sy
2670: 73 74 65 6d 20 28 63 6f 6e 63 20 22 62 61 73 68 stem (conc "bash
2680: 20 2d 63 20 27 72 6d 20 2d 66 20 60 67 72 65 70 -c 'rm -f `grep
2690: 20 2d 69 6c 20 65 78 69 74 69 6e 67 20 22 20 61 -il exiting " a
26a0: 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 2f 73 reapath "/logs/s
26b0: 65 72 76 65 72 2d 2a 2d 2a 2e 6c 6f 67 20 32 3e erver-*-*.log 2>
26c0: 20 2f 64 65 76 2f 6e 75 6c 6c 60 27 22 29 29 29 /dev/null`'")))
26d0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
26e0: 20 20 20 28 73 65 72 76 65 72 2d 6c 6f 67 73 20 (server-logs
26f0: 20 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 61 72 (glob (conc ar
2700: 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 2f 73 65 eapath "/logs/se
2710: 72 76 65 72 2d 2a 2d 2a 2e 6c 6f 67 22 29 29 29 rver-*-*.log")))
2720: 0a 3b 3b 20 09 20 20 20 20 20 20 20 28 6e 75 6d .;; . (num
2730: 2d 73 65 72 76 2d 6c 6f 67 73 20 28 6c 65 6e 67 -serv-logs (leng
2740: 74 68 20 73 65 72 76 65 72 2d 6c 6f 67 73 29 29 th server-logs))
2750: 29 0a 3b 3b 20 09 20 20 28 69 66 20 28 6f 72 20 ).;; . (if (or
2760: 28 6e 75 6c 6c 3f 20 73 65 72 76 65 72 2d 6c 6f (null? server-lo
2770: 67 73 29 20 28 3d 20 6e 75 6d 2d 73 65 72 76 2d gs) (= num-serv-
2780: 6c 6f 67 73 20 30 29 29 0a 3b 3b 20 20 20 20 20 logs 0)).;;
2790: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
27a0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
27b0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
27c0: 6e 74 20 32 20 20 2a 64 65 66 61 75 6c 74 2d 6c nt 2 *default-l
27d0: 6f 67 2d 70 6f 72 74 2a 20 22 54 68 65 72 65 20 og-port* "There
27e0: 61 72 65 20 6e 6f 20 73 65 72 76 65 72 73 20 72 are no servers r
27f0: 75 6e 6e 69 6e 67 20 61 74 20 22 20 28 63 6f 6d unning at " (com
2800: 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 29 mon:human-time))
2810: 0a 3b 3b 20 09 20 20 20 20 20 20 20 20 20 27 28 .;; . '(
2820: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
2830: 20 20 20 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 ).;; . (
2840: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 let loop ((hed
2850: 28 73 74 72 69 6e 67 2d 63 68 6f 6d 70 20 28 63 (string-chomp (c
2860: 61 72 20 73 65 72 76 65 72 2d 6c 6f 67 73 29 29 ar server-logs))
2870: 29 0a 3b 3b 20 09 09 09 20 28 74 61 6c 20 20 28 ).;; ... (tal (
2880: 63 64 72 20 73 65 72 76 65 72 2d 6c 6f 67 73 29 cdr server-logs)
2890: 29 0a 3b 3b 20 09 09 09 20 28 72 65 73 20 27 28 ).;; ... (res '(
28a0: 29 29 29 0a 3b 3b 20 09 09 28 6c 65 74 2a 20 28 ))).;; ..(let* (
28b0: 28 6d 6f 64 2d 74 69 6d 65 20 20 28 68 61 6e 64 (mod-time (hand
28c0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 3b 3b le-exceptions.;;
28d0: 20 09 09 09 09 20 20 20 65 78 6e 0a 3b 3b 20 09 .... exn.;; .
28e0: 09 09 09 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 ... (begin.;;
28f0: 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
2900: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
2910: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 72 76 -log-port* "serv
2920: 65 72 3a 67 65 74 2d 6c 69 73 74 3a 20 66 61 69 er:get-list: fai
2930: 6c 65 64 20 74 6f 20 67 65 74 20 6d 6f 64 69 66 led to get modif
2940: 69 63 61 74 69 6f 6e 20 74 69 6d 65 20 6f 6e 20 ication time on
2950: 22 20 68 65 64 20 22 2c 20 65 78 6e 3d 22 20 65 " hed ", exn=" e
2960: 78 6e 29 0a 3b 3b 20 09 09 09 09 20 20 20 20 20 xn).;; ....
2970: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2980: 29 29 20 3b 3b 20 30 0a 3b 3b 20 09 09 09 09 20 )) ;; 0.;; ....
2990: 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 (file-modifica
29a0: 74 69 6f 6e 2d 74 69 6d 65 20 68 65 64 29 29 29 tion-time hed)))
29b0: 20 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f 20 2a ;; default to *
29c0: 76 65 72 79 2a 20 6f 6c 64 20 73 6f 20 6c 6f 67 very* old so log
29d0: 20 67 65 74 73 20 69 67 6e 6f 72 65 64 20 69 66 gets ignored if
29e0: 20 64 65 6c 65 74 65 64 0a 3b 3b 20 09 09 20 20 deleted.;; ..
29f0: 20 20 20 20 20 28 64 6f 77 6e 2d 74 69 6d 65 20 (down-time
2a00: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
2a10: 6e 64 73 29 20 6d 6f 64 2d 74 69 6d 65 29 29 0a nds) mod-time)).
2a20: 3b 3b 20 09 09 20 20 20 20 20 20 20 28 73 65 72 ;; .. (ser
2a30: 76 2d 64 61 74 20 20 28 69 66 20 28 6f 72 20 28 v-dat (if (or (
2a40: 3c 20 6e 75 6d 2d 73 65 72 76 2d 6c 6f 67 73 20 < num-serv-logs
2a50: 31 30 29 0a 3b 3b 20 09 09 09 09 20 20 09 20 20 10).;; .... .
2a60: 28 3c 20 64 6f 77 6e 2d 74 69 6d 65 20 39 30 30 (< down-time 900
2a70: 29 29 20 3b 3b 20 64 61 79 2d 73 65 63 6f 6e 64 )) ;; day-second
2a80: 73 29 29 0a 3b 3b 20 09 09 09 09 20 20 20 20 20 s)).;; ....
2a90: 20 28 73 65 72 76 65 72 3a 6c 6f 67 66 2d 67 65 (server:logf-ge
2aa0: 74 2d 73 74 61 72 74 2d 69 6e 66 6f 20 68 65 64 t-start-info hed
2ab0: 29 0a 3b 3b 20 09 09 09 09 20 20 20 20 20 20 27 ).;; .... '
2ac0: 28 29 29 29 20 3b 3b 20 64 6f 6e 27 74 20 77 61 ())) ;; don't wa
2ad0: 73 74 65 20 74 69 6d 65 20 70 72 6f 63 65 73 73 ste time process
2ae0: 69 6e 67 20 73 65 72 76 65 72 20 66 69 6c 65 73 ing server files
2af0: 20 6e 6f 74 20 74 6f 75 63 68 65 64 20 69 6e 20 not touched in
2b00: 74 68 65 20 31 35 20 6d 69 6e 75 74 65 73 20 69 the 15 minutes i
2b10: 66 20 74 68 65 72 65 20 61 72 65 20 6d 6f 72 65 f there are more
2b20: 20 74 68 61 6e 20 74 65 6e 20 73 65 72 76 65 72 than ten server
2b30: 73 20 74 6f 20 6c 6f 6f 6b 20 61 74 0a 3b 3b 20 s to look at.;;
2b40: 09 09 20 20 20 20 20 20 20 28 73 65 72 76 2d 72 .. (serv-r
2b50: 65 63 20 28 63 6f 6e 73 20 6d 6f 64 2d 74 69 6d ec (cons mod-tim
2b60: 65 20 73 65 72 76 2d 64 61 74 29 29 0a 3b 3b 20 e serv-dat)).;;
2b70: 09 09 20 20 20 20 20 20 20 28 66 6d 61 74 63 68 .. (fmatch
2b80: 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 (string-match
2b90: 20 66 6e 61 6d 65 2d 72 78 20 68 65 64 29 29 0a fname-rx hed)).
2ba0: 3b 3b 20 09 09 20 20 20 20 20 20 20 28 70 69 64 ;; .. (pid
2bb0: 20 20 20 20 20 20 28 69 66 20 66 6d 61 74 63 68 (if fmatch
2bc0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
2bd0: 20 28 6c 69 73 74 2d 72 65 66 20 66 6d 61 74 63 (list-ref fmatc
2be0: 68 20 32 29 29 20 23 66 29 29 0a 3b 3b 20 09 09 h 2)) #f)).;; ..
2bf0: 20 20 20 20 20 20 20 28 6e 65 77 2d 72 65 73 20 (new-res
2c00: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 73 65 72 76 (if (null? serv
2c10: 2d 64 61 74 29 0a 3b 3b 20 09 09 09 09 20 20 20 -dat).;; ....
2c20: 20 20 72 65 73 0a 3b 3b 20 09 09 09 09 20 20 20 res.;; ....
2c30: 20 20 28 63 6f 6e 73 20 28 61 70 70 65 6e 64 20 (cons (append
2c40: 73 65 72 76 2d 72 65 63 20 28 6c 69 73 74 20 70 serv-rec (list p
2c50: 69 64 29 29 20 72 65 73 29 29 29 29 20 3b 3b 20 id)) res)))) ;;
2c60: 61 6e 79 20 63 68 61 6e 67 65 73 20 74 6f 20 6e any changes to n
2c70: 75 6d 62 65 72 20 6f 66 20 65 6c 65 6d 65 6e 74 umber of element
2c80: 73 20 69 6e 20 6e 65 77 2d 72 65 73 20 77 69 6c s in new-res wil
2c90: 6c 20 64 69 72 63 74 6c 79 20 61 66 66 65 63 74 l dirctly affect
2ca0: 20 73 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e server:record->
2cb0: 75 72 6c 2c 73 65 72 76 65 72 3a 72 65 63 6f 72 url,server:recor
2cc0: 64 2d 3e 69 64 2c 73 65 72 76 65 72 3a 6b 69 6c d->id,server:kil
2cd0: 6c 2c 73 65 72 76 65 72 3a 67 65 74 2d 6e 75 6d l,server:get-num
2ce0: 2d 61 6c 69 76 65 20 77 68 69 63 68 20 75 73 65 -alive which use
2cf0: 73 20 6d 61 74 63 68 20 6c 65 74 20 0a 3b 3b 20 s match let .;;
2d00: 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 .. (if (null? t
2d10: 61 6c 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 28 al).;; .. (
2d20: 69 66 20 28 61 6e 64 20 6c 69 6d 69 74 0a 3b 3b if (and limit.;;
2d30: 20 09 09 09 20 20 20 20 20 20 20 28 3e 20 28 6c ... (> (l
2d40: 65 6e 67 74 68 20 6e 65 77 2d 72 65 73 29 20 6c ength new-res) l
2d50: 69 6d 69 74 29 29 0a 3b 3b 20 09 09 09 20 20 6e imit)).;; ... n
2d60: 65 77 2d 72 65 73 20 3b 3b 20 28 74 61 6b 65 20 ew-res ;; (take
2d70: 6e 65 77 2d 72 65 73 20 6c 69 6d 69 74 29 20 20 new-res limit)
2d80: 3c 3d 20 6e 65 65 64 20 69 6e 74 65 6c 6c 69 67 <= need intellig
2d90: 65 6e 74 20 73 6f 72 74 69 6e 67 20 62 65 66 6f ent sorting befo
2da0: 72 65 20 74 68 69 73 20 77 69 6c 6c 20 77 6f 72 re this will wor
2db0: 6b 0a 3b 3b 20 09 09 09 20 20 6e 65 77 2d 72 65 k.;; ... new-re
2dc0: 73 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 28 6c s).;; .. (l
2dd0: 6f 6f 70 20 28 73 74 72 69 6e 67 2d 63 68 6f 6d oop (string-chom
2de0: 70 20 28 63 61 72 20 74 61 6c 29 29 20 28 63 64 p (car tal)) (cd
2df0: 72 20 74 61 6c 29 20 6e 65 77 2d 72 65 73 29 29 r tal) new-res))
2e00: 29 29 29 29 29 29 29 0a 0a 23 3b 28 64 65 66 69 )))))))..#;(defi
2e10: 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6e ne (server:get-n
2e20: 75 6d 2d 61 6c 69 76 65 20 73 72 76 6c 73 74 29 um-alive srvlst)
2e30: 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 61 6c . (let ((num-al
2e40: 69 76 65 20 30 29 29 0a 20 20 20 20 28 66 6f 72 ive 0)). (for
2e50: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
2e60: 64 61 20 28 73 65 72 76 65 72 29 0a 20 20 20 20 da (server).
2e70: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
2e80: 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 ptions.
2e90: 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 28 62 exn. (b
2ea0: 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 egin .
2eb0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2ec0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
2ed0: 2d 70 6f 72 74 2a 20 20 22 55 6e 61 62 6c 65 20 -port* "Unable
2ee0: 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 73 74 to get server st
2ef0: 61 72 74 2d 74 69 6d 65 20 61 6e 64 2f 6f 72 20 art-time and/or
2f00: 6d 6f 64 2d 74 69 6d 65 20 66 72 6f 6d 20 22 20 mod-time from "
2f10: 73 65 72 76 65 72 20 22 2c 20 65 78 6e 3d 22 20 server ", exn="
2f20: 65 78 6e 29 29 0a 20 20 20 20 20 20 20 28 6d 61 exn)). (ma
2f30: 74 63 68 2d 6c 65 74 20 28 28 28 6d 6f 64 2d 74 tch-let (((mod-t
2f40: 69 6d 65 20 68 6f 73 74 20 70 6f 72 74 20 73 74 ime host port st
2f50: 61 72 74 2d 74 69 6d 65 20 73 65 72 76 65 72 2d art-time server-
2f60: 69 64 20 70 69 64 29 0a 09 09 20 20 20 20 73 65 id pid)... se
2f70: 72 76 65 72 29 29 0a 09 20 28 6c 65 74 2a 20 28 rver)).. (let* (
2f80: 28 75 70 74 69 6d 65 20 20 28 2d 20 28 63 75 72 (uptime (- (cur
2f90: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6d 6f rent-seconds) mo
2fa0: 64 2d 74 69 6d 65 29 29 0a 09 09 28 72 75 6e 74 d-time))...(runt
2fb0: 69 6d 65 20 28 69 66 20 73 74 61 72 74 2d 74 69 ime (if start-ti
2fc0: 6d 65 0a 09 09 09 20 20 20 20 20 28 2d 20 6d 6f me.... (- mo
2fd0: 64 2d 74 69 6d 65 20 73 74 61 72 74 2d 74 69 6d d-time start-tim
2fe0: 65 29 0a 09 09 09 20 20 20 20 20 30 29 29 29 0a e).... 0))).
2ff0: 09 20 20 20 28 69 66 20 28 3c 20 75 70 74 69 6d . (if (< uptim
3000: 65 20 35 29 28 73 65 74 21 20 6e 75 6d 2d 61 6c e 5)(set! num-al
3010: 69 76 65 20 28 2b 20 6e 75 6d 2d 61 6c 69 76 65 ive (+ num-alive
3020: 20 31 29 29 29 29 29 29 29 0a 20 20 20 20 20 73 1))))))). s
3030: 72 76 6c 73 74 29 0a 20 20 20 20 6e 75 6d 2d 61 rvlst). num-a
3040: 6c 69 76 65 29 29 0a 0a 3b 3b 20 3b 3b 20 67 69 live))..;; ;; gi
3050: 76 65 6e 20 61 20 6c 69 73 74 20 6f 66 20 73 65 ven a list of se
3060: 72 76 65 72 73 20 67 65 74 20 61 20 6c 69 73 74 rvers get a list
3070: 20 6f 66 20 76 61 6c 69 64 20 73 65 72 76 65 72 of valid server
3080: 73 2c 20 69 2e 65 2e 20 61 74 20 6c 65 61 73 74 s, i.e. at least
3090: 0a 3b 3b 20 3b 3b 20 31 30 20 73 65 63 6f 6e 64 .;; ;; 10 second
30a0: 73 20 6f 6c 64 2c 20 68 61 73 20 73 74 61 72 74 s old, has start
30b0: 65 64 20 61 6e 64 20 69 73 20 6c 65 73 73 20 74 ed and is less t
30c0: 68 61 6e 20 31 20 68 6f 75 72 20 6f 6c 64 20 61 han 1 hour old a
30d0: 6e 64 20 69 73 0a 3b 3b 20 3b 3b 20 61 63 74 69 nd is.;; ;; acti
30e0: 76 65 20 28 69 2e 65 2e 20 6d 6f 64 2d 74 69 6d ve (i.e. mod-tim
30f0: 65 20 3c 20 31 30 20 73 65 63 6f 6e 64 73 0a 3b e < 10 seconds.;
3100: 3b 20 3b 3b 0a 3b 3b 20 3b 3b 20 6d 6f 64 2d 74 ; ;;.;; ;; mod-t
3110: 69 6d 65 20 68 6f 73 74 20 70 6f 72 74 20 73 74 ime host port st
3120: 61 72 74 2d 74 69 6d 65 20 70 69 64 0a 3b 3b 20 art-time pid.;;
3130: 3b 3b 0a 3b 3b 20 3b 3b 20 73 6f 72 74 20 62 79 ;;.;; ;; sort by
3140: 20 73 74 61 72 74 2d 74 69 6d 65 20 64 65 73 63 start-time desc
3150: 65 6e 64 69 6e 67 2e 20 49 2e 65 2e 20 67 65 74 ending. I.e. get
3160: 20 74 68 65 20 6f 6c 64 65 73 74 20 66 69 72 73 the oldest firs
3170: 74 2e 20 59 6f 75 6e 67 20 73 65 72 76 65 72 73 t. Young servers
3180: 20 77 69 6c 6c 20 74 68 75 73 20 64 72 6f 70 20 will thus drop
3190: 6f 66 66 0a 3b 3b 20 3b 3b 20 61 6e 64 20 73 65 off.;; ;; and se
31a0: 72 76 65 72 73 20 73 68 6f 75 6c 64 20 73 74 69 rvers should sti
31b0: 63 6b 20 61 72 6f 75 6e 64 20 66 6f 72 20 61 62 ck around for ab
31c0: 6f 75 74 20 74 77 6f 20 68 6f 75 72 73 20 6f 72 out two hours or
31d0: 20 73 6f 2e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 so..;; ;;.;; (d
31e0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 efine (server:ge
31f0: 74 2d 62 65 73 74 20 73 72 76 6c 73 74 29 0a 3b t-best srvlst).;
3200: 3b 20 20 20 28 6c 65 74 2a 20 28 28 6e 75 6d 73 ; (let* ((nums
3210: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6e 75 6d (server:get-num
3220: 2d 73 65 72 76 65 72 73 29 29 0a 3b 3b 20 09 20 -servers)).;; .
3230: 28 6e 6f 77 20 20 28 63 75 72 72 65 6e 74 2d 73 (now (current-s
3240: 65 63 6f 6e 64 73 29 29 0a 3b 3b 20 09 20 28 73 econds)).;; . (s
3250: 6c 73 74 20 28 73 6f 72 74 0a 3b 3b 20 09 09 28 lst (sort.;; ..(
3260: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
3270: 72 65 63 29 0a 3b 3b 20 09 09 09 20 20 28 69 66 rec).;; ... (if
3280: 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 72 65 63 (and (list? rec
3290: 29 0a 3b 3b 20 09 09 09 09 20 20 20 28 3e 20 28 ).;; .... (> (
32a0: 6c 65 6e 67 74 68 20 72 65 63 29 20 32 29 29 0a length rec) 2)).
32b0: 3b 3b 20 09 09 09 20 20 20 20 20 20 28 6c 65 74 ;; ... (let
32c0: 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 6c ((start-time (l
32d0: 69 73 74 2d 72 65 66 20 72 65 63 20 33 29 29 0a ist-ref rec 3)).
32e0: 3b 3b 20 09 09 09 09 20 20 20 20 28 6d 6f 64 2d ;; .... (mod-
32f0: 74 69 6d 65 20 20 20 28 6c 69 73 74 2d 72 65 66 time (list-ref
3300: 20 72 65 63 20 30 29 29 29 0a 3b 3b 20 09 09 09 rec 0))).;; ...
3310: 09 3b 3b 20 28 70 72 69 6e 74 20 22 73 74 61 72 .;; (print "star
3320: 74 2d 74 69 6d 65 3a 20 22 20 73 74 61 72 74 2d t-time: " start-
3330: 74 69 6d 65 20 22 20 6d 6f 64 2d 74 69 6d 65 3a time " mod-time:
3340: 20 22 20 6d 6f 64 2d 74 69 6d 65 29 0a 3b 3b 20 " mod-time).;;
3350: 09 09 09 09 28 61 6e 64 20 73 74 61 72 74 2d 74 ....(and start-t
3360: 69 6d 65 20 6d 6f 64 2d 74 69 6d 65 0a 3b 3b 20 ime mod-time.;;
3370: 09 09 09 09 20 20 20 20 20 28 3e 20 28 2d 20 6e .... (> (- n
3380: 6f 77 20 73 74 61 72 74 2d 74 69 6d 65 29 20 30 ow start-time) 0
3390: 29 20 20 20 20 3b 3b 20 62 65 65 6e 20 72 75 6e ) ;; been run
33a0: 6e 69 6e 67 20 61 74 20 6c 65 61 73 74 20 30 20 ning at least 0
33b0: 73 65 63 6f 6e 64 73 0a 3b 3b 20 09 09 09 09 20 seconds.;; ....
33c0: 20 20 20 20 28 3c 20 28 2d 20 6e 6f 77 20 6d 6f (< (- now mo
33d0: 64 2d 74 69 6d 65 29 20 20 20 31 36 29 20 20 20 d-time) 16)
33e0: 3b 3b 20 73 74 69 6c 6c 20 61 6c 69 76 65 20 2d ;; still alive -
33f0: 20 66 69 6c 65 20 74 6f 75 63 68 65 64 20 69 6e file touched in
3400: 20 6c 61 73 74 20 31 36 20 73 65 63 6f 6e 64 73 last 16 seconds
3410: 0a 3b 3b 20 09 09 09 09 20 20 20 20 20 28 6f 72 .;; .... (or
3420: 20 28 6e 6f 74 20 28 63 6f 6e 66 69 67 66 3a 6c (not (configf:l
3430: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
3440: 2a 20 22 73 65 72 76 65 72 22 20 22 72 75 6e 74 * "server" "runt
3450: 69 6d 65 22 29 29 20 3b 3b 20 73 6b 69 70 20 69 ime")) ;; skip i
3460: 66 20 6e 6f 74 20 73 65 74 0a 3b 3b 20 09 09 09 f not set.;; ...
3470: 09 09 20 28 3c 20 28 2d 20 6e 6f 77 20 73 74 61 .. (< (- now sta
3480: 72 74 2d 74 69 6d 65 29 20 20 20 20 20 20 20 0a rt-time) .
3490: 3b 3b 20 09 09 09 09 09 20 20 20 20 28 2b 20 28 ;; ..... (+ (
34a0: 2d 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 - (string->numbe
34b0: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
34c0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
34d0: 65 72 76 65 72 22 20 22 72 75 6e 74 69 6d 65 22 erver" "runtime"
34e0: 29 29 0a 3b 3b 20 09 09 09 09 09 20 20 20 20 20 )).;; .....
34f0: 20 20 31 38 30 29 0a 3b 3b 20 09 09 09 09 09 20 180).;; .....
3500: 20 20 20 28 72 61 6e 64 6f 6d 20 33 36 30 29 29 (random 360))
3510: 29 29 20 3b 3b 20 75 6e 64 65 72 20 6f 6e 65 20 )) ;; under one
3520: 68 6f 75 72 20 72 75 6e 6e 69 6e 67 20 74 69 6d hour running tim
3530: 65 20 2b 2f 2d 20 31 38 30 0a 3b 3b 20 09 09 09 e +/- 180.;; ...
3540: 09 20 20 20 20 20 29 29 0a 3b 3b 20 09 09 09 20 . )).;; ...
3550: 20 20 20 20 20 23 66 29 29 0a 3b 3b 20 09 09 09 #f)).;; ...
3560: 73 72 76 6c 73 74 29 0a 3b 3b 20 09 09 28 6c 61 srvlst).;; ..(la
3570: 6d 62 64 61 20 28 61 20 62 29 0a 3b 3b 20 09 09 mbda (a b).;; ..
3580: 20 20 28 3c 20 28 6c 69 73 74 2d 72 65 66 20 61 (< (list-ref a
3590: 20 33 29 0a 3b 3b 20 09 09 20 20 20 20 20 28 6c 3).;; .. (l
35a0: 69 73 74 2d 72 65 66 20 62 20 33 29 29 29 29 29 ist-ref b 3)))))
35b0: 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 3e 20 ).;; (if (>
35c0: 28 6c 65 6e 67 74 68 20 73 6c 73 74 29 20 6e 75 (length slst) nu
35d0: 6d 73 29 0a 3b 3b 20 09 28 74 61 6b 65 20 73 6c ms).;; .(take sl
35e0: 73 74 20 6e 75 6d 73 29 0a 3b 3b 20 09 73 6c 73 st nums).;; .sls
35f0: 74 29 29 29 0a 0a 3b 3b 20 3b 3b 20 73 77 69 74 t)))..;; ;; swit
3600: 63 68 20 66 72 6f 6d 20 73 65 72 76 65 72 3a 67 ch from server:g
3610: 65 74 2d 6c 69 73 74 20 74 6f 20 73 65 72 76 65 et-list to serve
3620: 72 3a 67 65 74 2d 73 65 72 76 65 72 73 2d 69 6e r:get-servers-in
3630: 66 6f 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 fo.;; ;;.;; (def
3640: 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d ine (server:get-
3650: 66 69 72 73 74 2d 62 65 73 74 20 61 72 65 61 70 first-best areap
3660: 61 74 68 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 ath).;; (let (
3670: 28 73 72 76 72 73 20 28 73 65 72 76 65 72 3a 67 (srvrs (server:g
3680: 65 74 2d 62 65 73 74 20 28 73 65 72 76 65 72 3a et-best (server:
3690: 67 65 74 2d 6c 69 73 74 20 61 72 65 61 70 61 74 get-list areapat
36a0: 68 29 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 h)))).;; (if
36b0: 20 28 61 6e 64 20 73 72 76 72 73 0a 3b 3b 20 09 (and srvrs.;; .
36c0: 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (not (null?
36d0: 20 73 72 76 72 73 29 29 29 0a 3b 3b 20 09 28 63 srvrs))).;; .(c
36e0: 61 72 20 73 72 76 72 73 29 0a 3b 3b 20 09 23 66 ar srvrs).;; .#f
36f0: 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 ))).;; .;; (defi
3700: 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 72 ne (server:get-r
3710: 61 6e 64 2d 62 65 73 74 20 61 72 65 61 70 61 74 and-best areapat
3720: 68 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 73 h).;; (let ((s
3730: 72 76 72 73 20 28 73 65 72 76 65 72 3a 67 65 74 rvrs (server:get
3740: 2d 62 65 73 74 20 28 73 65 72 76 65 72 3a 67 65 -best (server:ge
3750: 74 2d 6c 69 73 74 20 61 72 65 61 70 61 74 68 29 t-list areapath)
3760: 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 ))).;; (if (
3770: 61 6e 64 20 28 6c 69 73 74 3f 20 73 72 76 72 73 and (list? srvrs
3780: 29 0a 3b 3b 20 09 20 20 20 20 20 28 6e 6f 74 20 ).;; . (not
3790: 28 6e 75 6c 6c 3f 20 73 72 76 72 73 29 29 29 0a (null? srvrs))).
37a0: 3b 3b 20 09 28 6c 65 74 2a 20 28 28 6c 65 6e 20 ;; .(let* ((len
37b0: 28 6c 65 6e 67 74 68 20 73 72 76 72 73 29 29 0a (length srvrs)).
37c0: 3b 3b 20 09 20 20 20 20 20 20 20 28 69 64 78 20 ;; . (idx
37d0: 28 72 61 6e 64 6f 6d 20 6c 65 6e 29 29 29 0a 3b (random len))).;
37e0: 3b 20 09 20 20 28 6c 69 73 74 2d 72 65 66 20 73 ; . (list-ref s
37f0: 72 76 72 73 20 69 64 78 29 29 0a 3b 3b 20 09 23 rvrs idx)).;; .#
3800: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 f)))..(define (s
3810: 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e 69 64 erver:record->id
3820: 20 73 65 72 76 72 29 0a 20 20 28 68 61 6e 64 6c servr). (handl
3830: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
3840: 65 78 6e 0a 20 20 20 28 62 65 67 69 6e 20 0a 20 exn. (begin .
3850: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3860: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
3870: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 55 6e 61 -log-port* "Una
3880: 62 6c 65 20 74 6f 20 67 65 74 20 73 65 72 76 65 ble to get serve
3890: 72 20 69 64 20 66 72 6f 6d 20 22 20 73 65 72 76 r id from " serv
38a0: 72 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 20 r ", exn=" exn)
38b0: 20 20 20 20 0a 20 20 20 23 66 29 0a 20 20 28 6d . #f). (m
38c0: 61 74 63 68 2d 6c 65 74 20 28 28 28 68 6f 73 74 atch-let (((host
38d0: 20 70 6f 72 74 20 73 74 61 72 74 2d 74 69 6d 65 port start-time
38e0: 20 73 65 72 76 65 72 2d 69 64 20 70 69 64 29 0a server-id pid).
38f0: 09 20 20 20 20 20 20 20 73 65 72 76 72 29 29 0a . servr)).
3900: 20 20 20 20 28 69 66 20 73 65 72 76 65 72 2d 69 (if server-i
3910: 64 0a 09 73 65 72 76 65 72 2d 69 64 0a 09 23 66 d..server-id..#f
3920: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
3930: 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e 75 72 erver:record->ur
3940: 6c 20 73 65 72 76 72 29 0a 20 20 28 68 61 6e 64 l servr). (hand
3950: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
3960: 20 65 78 6e 0a 20 20 20 28 62 65 67 69 6e 20 0a exn. (begin .
3970: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3980: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
3990: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 55 6e t-log-port* "Un
39a0: 61 62 6c 65 20 74 6f 20 67 65 74 20 73 65 72 76 able to get serv
39b0: 65 72 20 75 72 6c 20 66 72 6f 6d 20 22 20 73 65 er url from " se
39c0: 72 76 72 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e rvr ", exn=" exn
39d0: 29 20 20 20 20 20 0a 20 20 20 23 66 29 0a 20 20 ) . #f).
39e0: 28 6d 61 74 63 68 2d 6c 65 74 20 28 28 28 68 6f (match-let (((ho
39f0: 73 74 20 70 6f 72 74 20 73 74 61 72 74 2d 74 69 st port start-ti
3a00: 6d 65 20 73 65 72 76 65 72 2d 69 64 20 70 69 64 me server-id pid
3a10: 29 0a 09 20 20 20 20 20 20 20 73 65 72 76 72 29 ).. servr)
3a20: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 68 ). (if (and h
3a30: 6f 73 74 20 70 6f 72 74 29 0a 09 28 63 6f 6e 63 ost port)..(conc
3a40: 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 29 0a host ":" port).
3a50: 09 23 66 29 29 29 29 0a 0a 0a 3b 3b 20 69 66 20 .#f))))...;; if
3a60: 73 65 72 76 65 72 2d 73 74 61 72 74 2d 6c 61 73 server-start-las
3a70: 74 20 65 78 69 73 74 73 2c 20 61 6e 64 20 77 61 t exists, and wa
3a80: 73 6e 27 74 20 6f 6c 64 20 65 6e 6f 75 67 68 2c sn't old enough,
3a90: 20 77 61 69 74 20 3c 69 64 6c 65 20 74 69 6d 65 wait <idle time
3aa0: 3e 20 2b 20 31 2c 20 74 68 65 6e 20 63 61 6c 6c > + 1, then call
3ab0: 20 74 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 72 this function r
3ac0: 65 63 75 72 73 69 76 65 6c 79 20 75 6e 74 69 6c ecursively until
3ad0: 20 69 74 20 69 73 20 6f 6c 64 20 65 6e 6f 75 67 it is old enoug
3ae0: 68 2e 0a 3b 3b 20 69 66 20 69 74 20 69 73 20 6f h..;; if it is o
3af0: 6c 64 20 65 6e 6f 75 67 68 2c 20 6f 76 65 72 77 ld enough, overw
3b00: 72 69 74 65 20 69 74 20 61 6e 64 20 77 61 69 74 rite it and wait
3b10: 20 30 2e 32 35 20 73 65 63 6f 6e 64 73 2e 0a 3b 0.25 seconds..;
3b20: 3b 20 69 66 20 69 74 20 74 68 65 6e 20 68 61 73 ; if it then has
3b30: 20 74 68 65 20 77 72 6f 6e 67 20 73 65 72 76 65 the wrong serve
3b40: 72 20 6b 65 79 2c 20 77 61 69 74 20 3c 69 64 6c r key, wait <idl
3b50: 65 20 74 69 6d 65 3e 20 2b 20 31 20 61 6e 64 20 e time> + 1 and
3b60: 63 61 6c 6c 20 74 68 69 73 20 66 75 6e 63 74 69 call this functi
3b70: 6f 6e 20 72 65 63 75 72 73 69 76 65 6c 79 2e 0a on recursively..
3b80: 3b 3b 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 65 ;;.#;(define (se
3b90: 72 76 65 72 3a 77 61 69 74 2d 66 6f 72 2d 73 65 rver:wait-for-se
3ba0: 72 76 65 72 2d 73 74 61 72 74 2d 6c 61 73 74 2d rver-start-last-
3bb0: 66 6c 61 67 20 61 72 65 61 70 61 74 68 29 0a 20 flag areapath).
3bc0: 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 2d 66 (let* ((start-f
3bd0: 6c 61 67 20 28 63 6f 6e 63 20 61 72 65 61 70 61 lag (conc areapa
3be0: 74 68 20 22 2f 6c 6f 67 73 2f 73 65 72 76 65 72 th "/logs/server
3bf0: 2d 73 74 61 72 74 2d 6c 61 73 74 22 29 29 0a 09 -start-last"))..
3c00: 20 3b 3b 3b 20 54 48 49 53 20 49 4e 54 45 52 41 ;;; THIS INTERA
3c10: 43 54 53 20 57 49 54 48 20 5b 73 65 72 76 65 72 CTS WITH [server
3c20: 5d 20 74 69 6d 65 6f 75 74 2e 20 53 75 67 67 65 ] timeout. Sugge
3c30: 73 74 20 75 73 69 6e 67 20 30 2e 31 20 6f 72 20 st using 0.1 or
3c40: 61 62 6f 76 65 20 66 6f 72 20 74 69 6d 65 6f 75 above for timeou
3c50: 74 20 28 36 20 73 65 63 6f 6e 64 73 29 0a 09 20 t (6 seconds)..
3c60: 28 69 64 6c 65 74 69 6d 65 20 20 20 20 28 63 6f (idletime (co
3c70: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d nfigf:lookup-num
3c80: 62 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 ber *configdat*
3c90: 22 73 65 72 76 65 72 22 20 22 69 64 6c 65 74 69 "server" "idleti
3ca0: 6d 65 22 20 64 65 66 61 75 6c 74 3a 20 34 29 29 me" default: 4))
3cb0: 0a 09 20 28 73 65 72 76 65 72 2d 6b 65 79 20 28 .. (server-key (
3cc0: 63 6f 6e 63 20 28 67 65 74 2d 68 6f 73 74 2d 6e conc (get-host-n
3cd0: 61 6d 65 29 20 22 2d 22 20 28 63 75 72 72 65 6e ame) "-" (curren
3ce0: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 t-process-id))))
3cf0: 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 . (if (file-e
3d00: 78 69 73 74 73 3f 20 73 74 61 72 74 2d 66 6c 61 xists? start-fla
3d10: 67 29 0a 09 28 6c 65 74 2a 20 28 28 66 6d 6f 64 g)..(let* ((fmod
3d20: 74 69 6d 65 20 28 66 69 6c 65 2d 6d 6f 64 69 66 time (file-modif
3d30: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 74 61 ication-time sta
3d40: 72 74 2d 66 6c 61 67 29 29 0a 09 20 20 20 20 20 rt-flag))..
3d50: 20 20 28 64 65 6c 74 61 20 20 20 20 28 2d 20 28 (delta (- (
3d60: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
3d70: 20 66 6d 6f 64 74 69 6d 65 29 29 0a 09 20 20 20 fmodtime))..
3d80: 20 20 20 20 28 6f 6c 64 2d 65 6e 6f 75 67 68 20 (old-enough
3d90: 20 20 28 3e 20 64 65 6c 74 61 20 69 64 6c 65 74 (> delta idlet
3da0: 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ime)).
3db0: 20 20 20 20 20 28 6e 65 77 2d 73 65 72 76 65 72 (new-server
3dc0: 2d 6b 65 79 20 22 22 29 29 0a 20 20 20 20 20 20 -key "")).
3dd0: 20 20 20 20 3b 3b 20 77 72 69 74 65 20 73 74 61 ;; write sta
3de0: 72 74 2d 66 6c 61 67 20 66 69 6c 65 2c 20 77 61 rt-flag file, wa
3df0: 69 74 20 30 2e 32 35 73 2c 20 74 68 65 6e 20 69 it 0.25s, then i
3e00: 66 20 70 72 65 76 69 6f 75 73 6c 79 20 74 68 65 f previously the
3e10: 20 73 74 61 72 74 2d 66 6c 61 67 20 66 69 6c 65 start-flag file
3e20: 20 77 61 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 was older than
3e30: 3c 69 64 6c 65 74 69 6d 65 3e 20 73 65 63 6f 6e <idletime> secon
3e40: 64 73 2c 20 61 6e 64 20 74 68 65 20 6e 65 77 20 ds, and the new
3e50: 66 69 6c 65 20 73 74 69 6c 6c 20 68 61 73 20 74 file still has t
3e60: 68 65 20 73 61 6d 65 20 73 65 72 76 65 72 20 6b he same server k
3e70: 65 79 20 61 73 20 79 6f 75 20 6a 75 73 74 20 77 ey as you just w
3e80: 72 6f 74 65 2c 20 72 65 74 75 72 6e 20 23 74 2e rote, return #t.
3e90: 0a 09 20 20 3b 3b 20 74 68 65 20 69 6e 74 65 6e .. ;; the inten
3ea0: 74 69 6f 6e 20 69 73 20 74 6f 20 6d 61 6b 65 20 tion is to make
3eb0: 73 75 72 65 20 6e 66 73 20 63 61 6e 20 72 65 61 sure nfs can rea
3ec0: 64 20 74 68 65 20 66 69 6c 65 20 77 65 20 6a 75 d the file we ju
3ed0: 73 74 20 77 72 6f 74 65 2c 20 61 6e 64 20 6d 61 st wrote, and ma
3ee0: 6b 65 20 73 75 72 65 20 69 74 20 77 61 73 20 77 ke sure it was w
3ef0: 72 69 74 74 65 6e 20 62 79 20 75 73 2c 20 61 6e ritten by us, an
3f00: 64 20 6e 6f 74 20 61 6e 6f 74 68 65 72 20 70 72 d not another pr
3f10: 6f 63 65 73 73 2e 0a 20 20 20 20 20 20 20 20 20 ocess..
3f20: 20 20 28 69 66 20 28 61 6e 64 20 6f 6c 64 2d 65 (if (and old-e
3f30: 6e 6f 75 67 68 0a 09 09 20 20 20 20 28 62 65 67 nough... (beg
3f40: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
3f50: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
3f60: 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 print-info 2 *de
3f70: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3f80: 22 57 72 69 74 69 6e 67 20 22 20 73 74 61 72 74 "Writing " start
3f90: 2d 66 6c 61 67 29 0a 09 09 20 20 20 20 20 20 28 -flag)... (
3fa0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 with-output-to-f
3fb0: 69 6c 65 20 73 74 61 72 74 2d 66 6c 61 67 20 28 ile start-flag (
3fc0: 6c 61 6d 62 64 61 20 28 29 20 28 70 72 69 6e 74 lambda () (print
3fd0: 20 73 65 72 76 65 72 2d 6b 65 79 29 29 29 0a 09 server-key)))..
3fe0: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
3ff0: 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 09 20 20 leep! 0.25)...
4000: 20 20 20 20 28 73 65 74 21 20 6e 65 77 2d 73 65 (set! new-se
4010: 72 76 65 72 2d 6b 65 79 20 28 77 69 74 68 2d 69 rver-key (with-i
4020: 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 73 nput-from-file s
4030: 74 61 72 74 2d 66 6c 61 67 20 28 6c 61 6d 62 64 tart-flag (lambd
4040: 61 20 28 29 20 28 72 65 61 64 2d 6c 69 6e 65 29 a () (read-line)
4050: 29 29 29 0a 09 09 20 20 20 20 20 20 28 65 71 75 )))... (equ
4060: 61 6c 3f 20 73 65 72 76 65 72 2d 6b 65 79 20 6e al? server-key n
4070: 65 77 2d 73 65 72 76 65 72 2d 6b 65 79 29 29 29 ew-server-key)))
4080: 0a 09 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 .. #t.
4090: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 49 66 ;; If
40a0: 20 65 69 74 68 65 72 20 6f 66 20 74 68 65 20 61 either of the a
40b0: 62 6f 76 65 20 63 6f 6e 64 69 74 69 6f 6e 73 20 bove conditions
40c0: 69 73 20 6e 6f 74 20 74 72 75 65 2c 20 70 72 69 is not true, pri
40d0: 6e 74 20 61 20 22 47 61 74 69 6e 67 20 73 65 72 nt a "Gating ser
40e0: 76 65 72 20 73 74 61 72 74 22 20 6d 65 73 73 61 ver start" messa
40f0: 67 65 2c 20 77 61 69 74 20 3c 69 64 6c 65 2d 74 ge, wait <idle-t
4100: 69 6d 65 3e 20 2b 20 31 2c 20 74 68 65 6e 20 63 ime> + 1, then c
4110: 61 6c 6c 20 74 68 69 73 20 66 75 6e 63 74 69 6f all this functio
4120: 6e 20 72 65 63 75 72 73 69 76 65 6c 79 2e 20 0a n recursively. .
4130: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
4140: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
4150: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
4160: 6f 67 2d 70 6f 72 74 2a 20 22 47 61 74 69 6e 67 og-port* "Gating
4170: 20 73 65 72 76 65 72 20 73 74 61 72 74 2c 20 6c server start, l
4180: 61 73 74 20 73 74 61 72 74 3a 20 22 0a 09 09 09 ast start: "....
4190: 09 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 . (seconds->ti
41a0: 6d 65 2d 73 74 72 69 6e 67 20 66 6d 6f 64 74 69 me-string fmodti
41b0: 6d 65 29 20 22 2c 20 74 69 6d 65 20 73 69 6e 63 me) ", time sinc
41c0: 65 20 6c 61 73 74 20 73 74 61 72 74 3a 20 22 20 e last start: "
41d0: 64 65 6c 74 61 20 22 2c 20 72 65 71 75 69 72 65 delta ", require
41e0: 64 20 69 64 6c 65 74 69 6d 65 3a 20 22 20 69 64 d idletime: " id
41f0: 6c 65 74 69 6d 65 20 22 2c 20 67 61 74 69 6e 67 letime ", gating
4200: 20 72 65 61 73 6f 6e 3a 22 20 28 69 66 20 6f 6c reason:" (if ol
4210: 64 2d 65 6e 6f 75 67 68 20 22 61 6e 6f 74 68 65 d-enough "anothe
4220: 72 20 6a 6f 62 20 73 74 61 72 74 65 64 20 61 20 r job started a
4230: 73 65 72 76 65 72 22 20 22 74 6f 6f 20 73 6f 6f server" "too soo
4240: 6e 20 74 6f 20 73 74 61 72 74 20 61 6e 6f 74 68 n to start anoth
4250: 65 72 20 73 65 72 76 65 72 22 29 29 0a 09 09 20 er server"))...
4260: 0a 09 09 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ... (thread-slee
4270: 70 21 20 28 20 2b 20 31 20 69 64 6c 65 74 69 6d p! ( + 1 idletim
4280: 65 29 29 0a 09 09 20 28 73 65 72 76 65 72 3a 77 e))... (server:w
4290: 61 69 74 2d 66 6f 72 2d 73 65 72 76 65 72 2d 73 ait-for-server-s
42a0: 74 61 72 74 2d 6c 61 73 74 2d 66 6c 61 67 20 61 tart-last-flag a
42b0: 72 65 61 70 61 74 68 29 29 29 29 29 29 29 0a 0a reapath)))))))..
42c0: 3b 3b 20 6f 6c 64 65 73 74 20 73 65 72 76 65 72 ;; oldest server
42d0: 20 61 6c 69 76 65 20 64 65 74 65 72 6d 69 6e 65 alive determine
42e0: 73 20 68 6f 73 74 20 74 68 65 6e 20 63 68 6f 6f s host then choo
42f0: 73 65 20 72 61 6e 64 6f 6d 20 6f 66 20 79 6f 75 se random of you
4300: 6e 67 65 73 74 0a 3b 3b 20 66 69 76 65 20 73 65 ngest.;; five se
4310: 72 76 65 72 73 20 6f 6e 20 74 68 61 74 20 68 6f rvers on that ho
4320: 73 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 st.;;.(define (s
4330: 65 72 76 65 72 3a 67 65 74 2d 73 65 72 76 65 72 erver:get-server
4340: 73 2d 69 6e 66 6f 20 61 72 65 61 70 61 74 68 29 s-info areapath)
4350: 0a 20 20 3b 3b 20 28 61 73 73 65 72 74 20 2a 74 . ;; (assert *t
4360: 6f 70 70 61 74 68 2a 20 22 46 41 54 41 4c 3a 20 oppath* "FATAL:
4370: 73 65 72 76 65 72 3a 67 65 74 2d 73 65 72 76 65 server:get-serve
4380: 72 73 2d 69 6e 66 6f 20 63 61 6c 6c 65 64 20 62 rs-info called b
4390: 65 66 6f 72 65 20 2a 74 6f 70 70 61 74 68 2a 20 efore *toppath*
43a0: 68 61 73 20 62 65 65 6e 20 73 65 74 2e 22 29 0a has been set.").
43b0: 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 69 6e (let* ((servin
43c0: 66 6f 64 69 72 20 28 73 65 72 76 65 72 3a 67 65 fodir (server:ge
43d0: 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 t-servinfo-dir a
43e0: 72 65 61 70 61 74 68 29 29 29 20 3b 3b 20 28 63 reapath))) ;; (c
43f0: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 22 2f 2e onc *toppath*"/.
4400: 73 65 72 76 69 6e 66 6f 22 29 29 29 0a 20 20 20 servinfo"))).
4410: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
4420: 65 78 69 73 74 73 3f 20 73 65 72 76 69 6e 66 6f exists? servinfo
4430: 64 69 72 29 29 0a 09 28 63 72 65 61 74 65 2d 64 dir))..(create-d
4440: 69 72 65 63 74 6f 72 79 20 73 65 72 76 69 6e 66 irectory servinf
4450: 6f 64 69 72 29 29 0a 20 20 20 20 28 6c 65 74 2a odir)). (let*
4460: 20 28 28 61 6c 6c 66 69 6c 65 73 20 20 20 20 28 ((allfiles (
4470: 67 6c 6f 62 20 28 63 6f 6e 63 20 73 65 72 76 69 glob (conc servi
4480: 6e 66 6f 64 69 72 22 2f 2a 22 29 29 29 0a 09 20 nfodir"/*")))..
4490: 20 20 28 72 65 73 20 20 20 20 20 20 20 20 20 28 (res (
44a0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
44b0: 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 )). (for-ea
44c0: 63 68 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 ch. (lambd
44d0: 61 20 28 66 29 0a 09 20 28 6c 65 74 2a 20 28 28 a (f).. (let* ((
44e0: 68 6f 73 74 70 6f 72 74 20 20 28 70 61 74 68 6e hostport (pathn
44f0: 61 6d 65 2d 73 74 72 69 70 2d 64 69 72 65 63 74 ame-strip-direct
4500: 6f 72 79 20 66 29 29 0a 09 09 28 73 65 72 76 65 ory f))...(serve
4510: 72 64 61 74 20 28 73 65 72 76 65 72 3a 6c 6f 67 rdat (server:log
4520: 66 2d 67 65 74 2d 73 74 61 72 74 2d 69 6e 66 6f f-get-start-info
4530: 20 66 29 29 29 0a 09 20 20 20 28 6d 61 74 63 68 f))).. (match
4540: 20 73 65 72 76 65 72 64 61 74 0a 09 20 20 20 20 serverdat..
4550: 20 28 28 68 6f 73 74 20 70 6f 72 74 20 73 74 61 ((host port sta
4560: 72 74 20 73 65 72 76 65 72 2d 69 64 20 70 69 64 rt server-id pid
4570: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 6e ).. (if (an
4580: 64 20 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 d host port star
4590: 74 20 73 65 72 76 65 72 2d 69 64 20 70 69 64 29 t server-id pid)
45a0: 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ... (hash-table
45b0: 2d 73 65 74 21 20 72 65 73 20 68 6f 73 74 70 6f -set! res hostpo
45c0: 72 74 20 73 65 72 76 65 72 64 61 74 29 0a 09 09 rt serverdat)...
45d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
45e0: 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 2 *default-l
45f0: 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 73 65 og-port* "bad se
4600: 72 76 65 72 20 69 6e 66 6f 20 66 6f 72 20 22 66 rver info for "f
4610: 22 3a 20 22 73 65 72 76 65 72 64 61 74 29 29 29 ": "serverdat)))
4620: 0a 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 .. (else..
4630: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4640: 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 -info 2 *default
4650: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 -log-port* "bad
4660: 73 65 72 76 65 72 20 69 6e 66 6f 20 66 6f 72 20 server info for
4670: 22 66 22 3a 20 22 73 65 72 76 65 72 64 61 74 29 "f": "serverdat)
4680: 29 29 29 29 0a 20 20 20 20 20 20 20 61 6c 6c 66 )))). allf
4690: 69 6c 65 73 29 0a 20 20 20 20 20 20 72 65 73 29 iles). res)
46a0: 29 29 0a 0a 3b 3b 20 63 68 65 63 6b 20 74 68 65 ))..;; check the
46b0: 20 2e 73 65 72 76 69 6e 66 6f 20 64 69 72 65 63 .servinfo direc
46c0: 74 6f 72 79 2c 20 61 72 65 20 74 68 65 72 65 20 tory, are there
46d0: 6f 74 68 65 72 20 73 65 72 76 65 72 73 20 72 75 other servers ru
46e0: 6e 6e 69 6e 67 20 6f 6e 20 74 68 69 73 0a 3b 3b nning on this.;;
46f0: 20 6f 72 20 61 6e 6f 74 68 65 72 20 68 6f 73 74 or another host
4700: 3f 0a 3b 3b 0a 3b 3b 20 72 65 74 75 72 6e 73 20 ?.;;.;; returns
4710: 23 74 20 3d 3e 20 6f 6b 20 74 6f 20 73 74 61 72 #t => ok to star
4720: 74 20 61 6e 6f 74 68 65 72 20 73 65 72 76 65 72 t another server
4730: 0a 3b 3b 20 20 20 20 20 20 20 20 20 23 66 20 3d .;; #f =
4740: 3e 20 6e 6f 74 20 6f 6b 20 74 6f 20 73 74 61 72 > not ok to star
4750: 74 20 61 6e 6f 74 68 65 72 20 73 65 72 76 65 72 t another server
4760: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 .;;.(define (ser
4770: 76 65 72 3a 6d 69 6e 69 6d 61 6c 2d 63 68 65 63 ver:minimal-chec
4780: 6b 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 73 k areapath). (s
4790: 65 72 76 65 72 3a 63 6c 65 61 6e 2d 75 70 2d 6f erver:clean-up-o
47a0: 6c 64 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 ld areapath). (
47b0: 6c 65 74 2a 20 28 28 73 72 76 64 69 72 20 20 20 let* ((srvdir
47c0: 20 20 20 28 73 65 72 76 65 72 3a 67 65 74 2d 73 (server:get-s
47d0: 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 ervinfo-dir area
47e0: 70 61 74 68 29 29 20 3b 3b 20 28 63 6f 6e 63 20 path)) ;; (conc
47f0: 61 72 65 61 70 61 74 68 22 2f 2e 73 65 72 76 69 areapath"/.servi
4800: 6e 66 6f 22 29 29 0a 09 20 28 73 65 72 76 72 73 nfo")).. (servrs
4810: 20 20 20 20 20 20 28 67 6c 6f 62 20 28 63 6f 6e (glob (con
4820: 63 20 73 72 76 64 69 72 22 2f 2a 22 29 29 29 0a c srvdir"/*"))).
4830: 09 20 28 74 68 69 73 68 6f 73 74 69 70 20 20 28 . (thishostip (
4840: 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d server:get-best-
4850: 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 28 67 guess-address (g
4860: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 0a et-host-name))).
4870: 09 20 28 74 68 69 73 73 65 72 76 72 73 20 20 28 . (thisservrs (
4880: 67 6c 6f 62 20 28 63 6f 6e 63 20 73 72 76 64 69 glob (conc srvdi
4890: 72 22 2f 22 74 68 69 73 68 6f 73 74 69 70 22 3a r"/"thishostip":
48a0: 2a 22 29 29 29 0a 09 20 28 68 6f 6d 65 68 6f 73 *"))).. (homehos
48b0: 74 69 6e 66 20 28 73 65 72 76 65 72 3a 63 68 6f tinf (server:cho
48c0: 6f 73 65 2d 73 65 72 76 65 72 20 61 72 65 61 70 ose-server areap
48d0: 61 74 68 20 27 68 6f 6d 65 68 6f 73 74 29 29 0a ath 'homehost)).
48e0: 09 20 28 68 61 76 65 68 6f 6d 65 20 20 20 20 28 . (havehome (
48f0: 63 61 72 20 68 6f 6d 65 68 6f 73 74 69 6e 66 29 car homehostinf)
4900: 29 0a 09 20 28 77 65 61 72 65 68 6f 6d 65 20 20 ).. (wearehome
4910: 20 28 63 64 72 20 68 6f 6d 65 68 6f 73 74 69 6e (cdr homehostin
4920: 66 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a f))). (debug:
4930: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
4940: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
4950: 74 68 69 73 68 6f 73 74 69 70 22 2c 20 68 61 76 thishostip", hav
4960: 65 20 68 6f 6d 65 68 6f 73 74 3a 20 22 68 61 76 e homehost: "hav
4970: 65 68 6f 6d 65 22 2c 20 77 65 20 61 72 65 20 68 ehome", we are h
4980: 6f 6d 65 68 6f 73 74 3a 20 22 77 65 61 72 65 68 omehost: "weareh
4990: 6f 6d 65 0a 09 09 20 20 20 20 20 20 22 2c 20 6e ome... ", n
49a0: 75 6d 73 65 72 76 65 72 73 3a 20 22 28 6c 65 6e umservers: "(len
49b0: 67 74 68 20 74 68 69 73 73 65 72 76 72 73 29 29 gth thisservrs))
49c0: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
49d0: 28 28 6e 6f 74 20 68 61 76 65 68 6f 6d 65 29 20 ((not havehome)
49e0: 23 74 29 20 3b 3b 20 6e 6f 20 68 6f 6d 65 68 6f #t) ;; no homeho
49f0: 73 74 20 79 65 74 2c 20 67 6f 20 66 6f 72 20 69 st yet, go for i
4a00: 74 0a 20 20 20 20 20 28 28 61 6e 64 20 68 61 76 t. ((and hav
4a10: 65 68 6f 6d 65 20 77 65 61 72 65 68 6f 6d 65 20 ehome wearehome
4a20: 28 3c 20 28 6c 65 6e 67 74 68 20 74 68 69 73 73 (< (length thiss
4a30: 65 72 76 72 73 29 20 32 30 29 29 20 23 74 29 20 ervrs) 20)) #t)
4a40: 3b 3b 20 77 65 20 61 72 65 20 68 6f 6d 65 20 61 ;; we are home a
4a50: 6e 64 20 6c 65 73 73 20 74 68 61 6e 20 32 30 20 nd less than 20
4a60: 73 65 72 76 65 72 73 2c 20 6f 6b 20 74 6f 20 73 servers, ok to s
4a70: 74 61 72 74 20 61 6e 6f 74 68 65 72 0a 20 20 20 tart another.
4a80: 20 20 28 28 61 6e 64 20 68 61 76 65 68 6f 6d 65 ((and havehome
4a90: 20 28 6e 6f 74 20 77 65 61 72 65 68 6f 6d 65 29 (not wearehome)
4aa0: 29 20 23 66 29 20 20 20 20 20 3b 3b 20 77 65 20 ) #f) ;; we
4ab0: 61 72 65 20 6e 6f 74 20 74 68 65 20 68 6f 6d 65 are not the home
4ac0: 20 68 6f 73 74 0a 20 20 20 20 20 28 28 61 6e 64 host. ((and
4ad0: 20 68 61 76 65 68 6f 6d 65 20 77 65 61 72 65 68 havehome weareh
4ae0: 6f 6d 65 20 28 3e 3d 20 28 6c 65 6e 67 74 68 20 ome (>= (length
4af0: 74 68 69 73 73 65 72 76 72 73 29 20 32 30 29 29 thisservrs) 20))
4b00: 20 23 66 29 20 3b 3b 20 68 61 76 65 20 65 6e 6f #f) ;; have eno
4b10: 75 67 68 20 72 75 6e 6e 69 6e 67 0a 20 20 20 20 ugh running.
4b20: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 64 65 (else. (de
4b30: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
4b40: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4b50: 57 41 52 4e 49 4e 47 3a 20 55 6e 72 65 63 6f 67 WARNING: Unrecog
4b60: 6e 69 73 65 64 20 73 63 65 6e 61 72 69 6f 2c 20 nised scenario,
4b70: 73 65 72 76 72 73 3d 22 73 65 72 76 72 73 22 2c servrs="servrs",
4b80: 20 74 68 69 73 68 6f 73 74 69 70 3d 22 74 68 69 thishostip="thi
4b90: 73 68 6f 73 74 69 70 22 2c 20 74 68 69 73 73 65 shostip", thisse
4ba0: 72 76 72 73 3d 22 74 68 69 73 73 65 72 76 72 73 rvrs="thisservrs
4bb0: 29 0a 20 20 20 20 20 20 23 74 29 29 29 29 0a 09 ). #t))))..
4bc0: 20 0a 0a 28 64 65 66 69 6e 65 20 73 65 72 76 65 ..(define serve
4bd0: 72 2d 6c 61 73 74 2d 73 74 61 72 74 20 30 29 0a r-last-start 0).
4be0: 0a 0a 3b 3b 20 6f 6c 64 65 73 74 20 73 65 72 76 ..;; oldest serv
4bf0: 65 72 20 61 6c 69 76 65 20 64 65 74 65 72 6d 69 er alive determi
4c00: 6e 65 73 20 68 6f 73 74 20 74 68 65 6e 20 63 68 nes host then ch
4c10: 6f 6f 73 65 20 72 61 6e 64 6f 6d 20 6f 66 20 79 oose random of y
4c20: 6f 75 6e 67 65 73 74 0a 3b 3b 20 66 69 76 65 20 oungest.;; five
4c30: 73 65 72 76 65 72 73 20 6f 6e 20 74 68 61 74 20 servers on that
4c40: 68 6f 73 74 0a 3b 3b 0a 3b 3b 20 6d 6f 64 65 3a host.;;.;; mode:
4c50: 0a 3b 3b 20 20 20 62 65 73 74 20 2d 20 67 65 74 .;; best - get
4c60: 20 62 65 73 74 20 73 65 72 76 65 72 20 28 72 61 best server (ra
4c70: 6e 64 6f 6d 20 6f 66 20 6e 65 77 65 73 74 20 66 ndom of newest f
4c80: 69 76 65 29 0a 3b 3b 20 20 20 68 6f 6d 65 20 2d ive).;; home -
4c90: 20 67 65 74 20 68 6f 6d 65 20 68 6f 73 74 20 62 get home host b
4ca0: 61 73 65 64 20 6f 6e 20 6f 6c 64 65 73 74 20 73 ased on oldest s
4cb0: 65 72 76 65 72 0a 3b 3b 20 20 20 69 6e 66 6f 20 erver.;; info
4cc0: 2d 20 70 72 69 6e 74 20 69 6e 66 6f 0a 28 64 65 - print info.(de
4cd0: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 63 68 6f fine (server:cho
4ce0: 6f 73 65 2d 73 65 72 76 65 72 20 61 72 65 61 70 ose-server areap
4cf0: 61 74 68 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 ath #!optional (
4d00: 6d 6f 64 65 20 27 62 65 73 74 29 29 0a 20 20 3b mode 'best)). ;
4d10: 3b 20 61 67 65 20 69 73 20 63 75 72 72 65 6e 74 ; age is current
4d20: 2d 73 74 61 72 74 74 69 6d 65 0a 20 20 3b 3b 20 -starttime. ;;
4d30: 66 69 6e 64 20 6f 6c 64 65 73 74 20 61 6c 69 76 find oldest aliv
4d40: 65 0a 20 20 3b 3b 20 20 20 31 2e 20 73 6f 72 74 e. ;; 1. sort
4d50: 20 62 79 20 61 67 65 20 61 73 63 65 6e 64 69 6e by age ascendin
4d60: 67 20 61 6e 64 20 70 69 6e 67 20 75 6e 74 69 6c g and ping until
4d70: 20 67 6f 6f 64 0a 20 20 3b 3b 20 66 69 6e 64 20 good. ;; find
4d80: 61 6c 69 76 65 20 72 61 6e 64 20 66 72 6f 6d 20 alive rand from
4d90: 79 6f 75 6e 67 65 73 74 0a 20 20 3b 3b 20 20 20 youngest. ;;
4da0: 31 2e 20 73 6f 72 74 20 62 79 20 61 67 65 20 64 1. sort by age d
4db0: 65 73 63 65 6e 64 69 6e 67 0a 20 20 3b 3b 20 20 escending. ;;
4dc0: 20 32 2e 20 74 61 6b 65 20 66 69 76 65 0a 20 20 2. take five.
4dd0: 3b 3b 20 20 20 33 2e 20 63 68 65 63 6b 20 61 6c ;; 3. check al
4de0: 69 76 65 2c 20 64 69 73 63 61 72 64 20 69 66 20 ive, discard if
4df0: 6e 6f 74 20 61 6e 64 20 72 65 70 65 61 74 0a 20 not and repeat.
4e00: 20 3b 3b 20 66 69 72 73 74 20 77 65 20 63 6c 65 ;; first we cle
4e10: 61 6e 20 75 70 20 6f 6c 64 20 73 65 72 76 65 72 an up old server
4e20: 20 66 69 6c 65 73 0a 20 20 28 61 73 73 65 72 74 files. (assert
4e30: 20 28 65 71 3f 20 28 72 6d 74 3a 74 72 61 6e 73 (eq? (rmt:trans
4e40: 70 6f 72 74 2d 6d 6f 64 65 29 20 27 68 74 74 70 port-mode) 'http
4e50: 29 20 22 46 41 54 41 4c 3a 20 73 65 72 76 65 72 ) "FATAL: server
4e60: 3a 72 75 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 :run called with
4e70: 20 72 6d 74 3a 74 72 61 6e 73 70 6f 72 74 2d 6d rmt:transport-m
4e80: 6f 64 65 3d 22 28 72 6d 74 3a 74 72 61 6e 73 70 ode="(rmt:transp
4e90: 6f 72 74 2d 6d 6f 64 65 29 29 0a 20 20 28 73 65 ort-mode)). (se
4ea0: 72 76 65 72 3a 63 6c 65 61 6e 2d 75 70 2d 6f 6c rver:clean-up-ol
4eb0: 64 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 6c d areapath). (l
4ec0: 65 74 2a 20 28 28 73 69 6e 63 65 2d 6c 61 73 74 et* ((since-last
4ed0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
4ee0: 6f 6e 64 73 29 20 73 65 72 76 65 72 2d 6c 61 73 onds) server-las
4ef0: 74 2d 73 74 61 72 74 29 29 0a 20 20 20 20 20 20 t-start)).
4f00: 20 20 28 73 65 72 76 65 72 2d 73 74 61 72 74 2d (server-start-
4f10: 64 65 6c 61 79 20 31 30 29 29 20 20 20 20 20 0a delay 10)) .
4f20: 20 20 20 20 28 69 66 20 28 20 3c 20 28 2d 20 28 (if ( < (- (
4f30: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
4f40: 20 73 65 72 76 65 72 2d 6c 61 73 74 2d 73 74 61 server-last-sta
4f50: 72 74 29 20 31 30 20 29 0a 20 20 20 20 20 20 28 rt) 10 ). (
4f60: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 28 64 begin. (d
4f70: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 ebug:print 2 *de
4f80: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
4f90: 22 73 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 "server:choose-s
4fa0: 65 72 76 65 72 3a 20 73 65 63 6f 6e 64 73 20 73 erver: seconds s
4fb0: 69 6e 63 65 20 6c 61 73 74 20 73 65 72 76 65 72 ince last server
4fc0: 20 73 74 61 72 74 3a 20 22 20 28 2d 20 28 63 75 start: " (- (cu
4fd0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 rrent-seconds) s
4fe0: 65 72 76 65 72 2d 6c 61 73 74 2d 73 74 61 72 74 erver-last-start
4ff0: 29 29 0a 20 20 20 20 20 20 20 20 28 64 65 62 75 )). (debu
5000: 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 g:print 2 *defau
5010: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 lt-log-port* "se
5020: 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 76 rver:choose-serv
5030: 65 72 3a 20 6c 61 73 74 20 73 65 72 76 65 72 20 er: last server
5040: 73 74 61 72 74 20 6c 65 73 73 20 74 68 61 6e 20 start less than
5050: 22 20 73 65 72 76 65 72 2d 73 74 61 72 74 2d 64 " server-start-d
5060: 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 73 20 61 elay " seconds a
5070: 67 6f 2e 20 53 6c 65 65 70 69 6e 67 20 22 20 73 go. Sleeping " s
5080: 65 72 76 65 72 2d 73 74 61 72 74 2d 64 65 6c 61 erver-start-dela
5090: 79 20 22 20 73 65 63 6f 6e 64 73 22 29 0a 20 20 y " seconds").
50a0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
50b0: 65 65 70 21 20 73 65 72 76 65 72 2d 73 74 61 72 eep! server-star
50c0: 74 2d 64 65 6c 61 79 29 0a 20 20 20 20 20 20 29 t-delay). )
50d0: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
50e0: 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c int 2 *default-l
50f0: 6f 67 2d 70 6f 72 74 2a 20 22 73 65 72 76 65 72 og-port* "server
5100: 3a 63 68 6f 6f 73 65 2d 73 65 72 76 65 72 3a 20 :choose-server:
5110: 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 6c 61 seconds since la
5120: 73 74 20 73 65 72 76 65 72 20 73 74 61 72 74 3a st server start:
5130: 20 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 " (- (current-s
5140: 65 63 6f 6e 64 73 29 20 73 65 72 76 65 72 2d 6c econds) server-l
5150: 61 73 74 2d 73 74 61 72 74 29 29 0a 20 20 20 20 ast-start)).
5160: 29 0a 20 20 29 0a 20 20 28 6c 65 74 2a 20 28 28 ). ). (let* ((
5170: 73 65 72 76 65 72 73 64 61 74 20 20 28 73 65 72 serversdat (ser
5180: 76 65 72 3a 67 65 74 2d 73 65 72 76 65 72 73 2d ver:get-servers-
5190: 69 6e 66 6f 20 61 72 65 61 70 61 74 68 29 29 0a info areapath)).
51a0: 09 20 28 73 65 72 76 6b 65 79 73 20 20 20 20 28 . (servkeys (
51b0: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
51c0: 73 65 72 76 65 72 73 64 61 74 29 29 0a 09 20 28 serversdat)).. (
51d0: 62 79 2d 74 69 6d 65 2d 61 73 63 20 28 69 66 20 by-time-asc (if
51e0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 73 65 72 76 (not (null? serv
51f0: 6b 65 79 73 29 29 20 3b 3b 20 4e 4f 54 45 3a 20 keys)) ;; NOTE:
5200: 4f 6c 64 65 73 74 20 69 73 20 6c 61 73 74 0a 09 Oldest is last..
5210: 09 09 20 20 28 73 6f 72 74 20 73 65 72 76 6b 65 .. (sort servke
5220: 79 73 20 3b 3b 20 6c 69 73 74 20 6f 66 20 22 68 ys ;; list of "h
5230: 6f 73 74 3a 70 6f 72 74 22 0a 09 09 09 09 28 6c ost:port".....(l
5240: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 09 09 ambda (a b).....
5250: 20 20 28 3e 3d 20 28 6c 69 73 74 2d 72 65 66 20 (>= (list-ref
5260: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
5270: 73 65 72 76 65 72 73 64 61 74 20 61 29 20 32 29 serversdat a) 2)
5280: 0a 09 09 09 09 20 20 20 20 20 20 28 6c 69 73 74 ..... (list
5290: 2d 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 -ref (hash-table
52a0: 2d 72 65 66 20 73 65 72 76 65 72 73 64 61 74 20 -ref serversdat
52b0: 62 29 20 32 29 29 29 29 0a 09 09 09 20 20 27 28 b) 2)))).... '(
52c0: 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a )))). (debug:
52d0: 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 print 2 *default
52e0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 72 76 -log-port* "serv
52f0: 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 76 65 72 er:choose-server
5300: 3a 20 73 65 72 76 65 72 73 64 61 74 3a 20 22 20 : serversdat: "
5310: 73 65 72 76 65 72 73 64 61 74 29 0a 20 20 20 20 serversdat).
5320: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a (debug:print 2 *
5330: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5340: 2a 20 22 73 65 72 76 65 72 3a 63 68 6f 6f 73 65 * "server:choose
5350: 2d 73 65 72 76 65 72 3a 20 73 65 72 76 6b 65 79 -server: servkey
5360: 73 3a 20 22 20 73 65 72 76 6b 65 79 73 29 0a 20 s: " servkeys).
5370: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
5380: 6c 3f 20 62 79 2d 74 69 6d 65 2d 61 73 63 29 29 l? by-time-asc))
5390: 0a 09 28 6c 65 74 2a 20 28 28 6f 6c 64 65 73 74 ..(let* ((oldest
53a0: 20 20 20 20 20 28 6c 61 73 74 20 62 79 2d 74 69 (last by-ti
53b0: 6d 65 2d 61 73 63 29 29 0a 09 20 20 20 20 20 20 me-asc))..
53c0: 20 28 6f 6c 64 65 73 74 2d 64 61 74 20 28 68 61 (oldest-dat (ha
53d0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 65 72 sh-table-ref ser
53e0: 76 65 72 73 64 61 74 20 6f 6c 64 65 73 74 29 29 versdat oldest))
53f0: 0a 09 20 20 20 20 20 20 20 28 68 6f 73 74 20 20 .. (host
5400: 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 6f (list-ref o
5410: 6c 64 65 73 74 2d 64 61 74 20 30 29 29 0a 09 20 ldest-dat 0))..
5420: 20 20 20 20 20 20 28 61 6c 6c 2d 76 61 6c 69 64 (all-valid
5430: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
5440: 61 20 28 78 29 0a 09 09 09 09 20 20 20 20 20 28 a (x)..... (
5450: 65 71 75 61 6c 3f 20 68 6f 73 74 20 28 6c 69 73 equal? host (lis
5460: 74 2d 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c t-ref (hash-tabl
5470: 65 2d 72 65 66 20 73 65 72 76 65 72 73 64 61 74 e-ref serversdat
5480: 20 78 29 20 30 29 29 29 0a 09 09 09 09 20 20 20 x) 0))).....
5490: 62 79 2d 74 69 6d 65 2d 61 73 63 29 29 0a 09 20 by-time-asc))..
54a0: 20 20 20 20 20 20 28 62 65 73 74 2d 74 65 6e 20 (best-ten
54b0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
54c0: 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 (if (> (leng
54d0: 74 68 20 61 6c 6c 2d 76 61 6c 69 64 29 20 31 31 th all-valid) 11
54e0: 29 0a 09 09 09 09 20 28 74 61 6b 65 20 28 64 72 )..... (take (dr
54f0: 6f 70 2d 72 69 67 68 74 20 61 6c 6c 2d 76 61 6c op-right all-val
5500: 69 64 20 31 29 20 31 30 29 20 3b 3b 20 72 65 6d id 1) 10) ;; rem
5510: 6f 76 65 20 74 68 65 20 6f 6c 64 65 73 74 20 66 ove the oldest f
5520: 72 6f 6d 20 63 6f 6e 73 69 64 65 72 61 74 69 6f rom consideratio
5530: 6e 20 73 6f 20 69 74 20 63 61 6e 20 61 67 65 20 n so it can age
5540: 6f 75 74 0a 09 09 09 09 20 28 69 66 20 28 3e 20 out..... (if (>
5550: 28 6c 65 6e 67 74 68 20 61 6c 6c 2d 76 61 6c 69 (length all-vali
5560: 64 29 20 38 29 0a 09 09 09 09 20 20 20 20 20 28 d) 8)..... (
5570: 64 72 6f 70 2d 72 69 67 68 74 20 61 6c 6c 2d 76 drop-right all-v
5580: 61 6c 69 64 20 31 29 0a 09 09 09 09 20 20 20 20 alid 1).....
5590: 20 61 6c 6c 2d 76 61 6c 69 64 29 29 29 29 0a 09 all-valid))))..
55a0: 20 20 20 20 20 20 20 28 6e 61 6d 65 73 2d 3e 64 (names->d
55b0: 61 74 73 20 28 6c 61 6d 62 64 61 20 28 6e 61 6d ats (lambda (nam
55c0: 65 73 29 0a 09 09 09 20 20 20 20 20 20 28 6d 61 es).... (ma
55d0: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 p (lambda (x)...
55e0: 09 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
55f0: 6c 65 2d 72 65 66 20 73 65 72 76 65 72 73 64 61 le-ref serversda
5600: 74 20 78 29 29 0a 09 09 09 09 20 20 20 6e 61 6d t x))..... nam
5610: 65 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 61 es))).. (a
5620: 6d 2d 68 6f 6d 65 3f 20 20 20 20 28 6c 61 6d 62 m-home? (lamb
5630: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 da ().... (
5640: 6c 65 74 2a 20 28 28 63 75 72 72 68 6f 73 74 20 let* ((currhost
5650: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
5660: 0a 09 09 09 09 20 20 20 20 20 28 62 65 73 74 61 ..... (besta
5670: 64 72 73 20 28 73 65 72 76 65 72 3a 67 65 74 2d drs (server:get-
5680: 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 best-guess-addre
5690: 73 73 20 63 75 72 72 68 6f 73 74 29 29 29 0a 09 ss currhost)))..
56a0: 09 09 09 28 6f 72 20 28 65 71 75 61 6c 3f 20 68 ...(or (equal? h
56b0: 6f 73 74 20 63 75 72 72 68 6f 73 74 29 0a 09 09 ost currhost)...
56c0: 09 09 20 20 20 20 28 65 71 75 61 6c 3f 20 68 6f .. (equal? ho
56d0: 73 74 20 62 65 73 74 61 64 72 73 29 29 29 29 29 st bestadrs)))))
56e0: 29 0a 09 20 20 28 63 61 73 65 20 6d 6f 64 65 0a ).. (case mode.
56f0: 09 20 20 20 20 28 28 69 6e 66 6f 29 0a 09 20 20 . ((info)..
5700: 20 20 20 28 70 72 69 6e 74 20 22 6f 6c 64 65 73 (print "oldes
5710: 74 3a 20 22 6f 6c 64 65 73 74 2d 64 61 74 22 2c t: "oldest-dat",
5720: 20 73 65 6c 65 63 74 65 64 20 68 6f 73 74 3a 20 selected host:
5730: 22 68 6f 73 74 22 2c 20 61 6c 6c 2d 76 61 6c 69 "host", all-vali
5740: 64 3a 20 22 61 6c 6c 2d 76 61 6c 69 64 29 0a 09 d: "all-valid)..
5750: 20 20 20 20 20 28 70 72 69 6e 74 20 22 79 6f 75 (print "you
5760: 6e 67 65 73 74 3a 20 22 28 68 61 73 68 2d 74 61 ngest: "(hash-ta
5770: 62 6c 65 2d 72 65 66 20 73 65 72 76 65 72 73 64 ble-ref serversd
5780: 61 74 20 28 63 61 72 20 61 6c 6c 2d 76 61 6c 69 at (car all-vali
5790: 64 29 29 29 29 0a 09 20 20 20 20 28 28 68 6f 6d d)))).. ((hom
57a0: 65 29 20 20 20 20 20 68 6f 73 74 29 0a 09 20 20 e) host)..
57b0: 20 20 28 28 68 6f 6d 65 68 6f 73 74 29 20 28 63 ((homehost) (c
57c0: 6f 6e 73 20 68 6f 73 74 20 28 61 6d 2d 68 6f 6d ons host (am-hom
57d0: 65 3f 29 29 29 20 3b 3b 20 73 68 75 74 20 75 70 e?))) ;; shut up
57e0: 20 6f 6c 64 20 63 6f 64 65 0a 09 20 20 20 20 28 old code.. (
57f0: 28 68 6f 6d 65 3f 29 20 20 20 20 28 61 6d 2d 68 (home?) (am-h
5800: 6f 6d 65 3f 29 29 0a 09 20 20 20 20 28 28 62 65 ome?)).. ((be
5810: 73 74 2d 74 65 6e 29 28 6e 61 6d 65 73 2d 3e 64 st-ten)(names->d
5820: 61 74 73 20 28 62 65 73 74 2d 74 65 6e 29 29 29 ats (best-ten)))
5830: 0a 09 20 20 20 20 28 28 61 6c 6c 2d 76 61 6c 69 .. ((all-vali
5840: 64 29 28 6e 61 6d 65 73 2d 3e 64 61 74 73 20 61 d)(names->dats a
5850: 6c 6c 2d 76 61 6c 69 64 29 29 0a 09 20 20 20 20 ll-valid))..
5860: 28 28 62 65 73 74 29 20 20 20 20 20 28 6c 65 74 ((best) (let
5870: 2a 20 28 28 62 65 73 74 2d 74 65 6e 20 28 62 65 * ((best-ten (be
5880: 73 74 2d 74 65 6e 29 29 0a 09 09 09 20 20 20 20 st-ten))....
5890: 20 20 20 28 6c 65 6e 20 20 20 20 20 20 20 28 6c (len (l
58a0: 65 6e 67 74 68 20 62 65 73 74 2d 74 65 6e 29 29 ength best-ten))
58b0: 29 0a 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 ).... (hash-tab
58c0: 6c 65 2d 72 65 66 20 73 65 72 76 65 72 73 64 61 le-ref serversda
58d0: 74 20 28 6c 69 73 74 2d 72 65 66 20 62 65 73 74 t (list-ref best
58e0: 2d 74 65 6e 20 28 72 61 6e 64 6f 6d 20 6c 65 6e -ten (random len
58f0: 29 29 29 29 29 0a 09 20 20 20 20 28 28 63 6f 75 ))))).. ((cou
5900: 6e 74 29 28 6c 65 6e 67 74 68 20 61 6c 6c 2d 76 nt)(length all-v
5910: 61 6c 69 64 29 29 0a 09 20 20 20 20 28 65 6c 73 alid)).. (els
5920: 65 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 e.. (debug:p
5930: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
5940: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
5950: 3a 20 69 6e 76 61 6c 69 64 20 63 6f 6d 6d 61 6e : invalid comman
5960: 64 20 22 6d 6f 64 65 29 0a 09 20 20 20 20 20 23 d "mode).. #
5970: 66 29 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 f)))..(begin..
5980: 28 73 65 72 76 65 72 3a 72 75 6e 20 61 72 65 61 (server:run area
5990: 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 path).
59a0: 28 73 65 74 21 20 73 65 72 76 65 72 2d 6c 61 73 (set! server-las
59b0: 74 2d 73 74 61 72 74 20 28 63 75 72 72 65 6e 74 t-start (current
59c0: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 3b 3b -seconds)).. ;;
59d0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
59e0: 33 29 0a 09 20 20 28 63 61 73 65 20 6d 6f 64 65 3).. (case mode
59f0: 0a 09 20 20 20 20 28 28 68 6f 6d 65 68 6f 73 74 .. ((homehost
5a00: 29 20 28 63 6f 6e 73 20 23 66 20 23 66 29 29 0a ) (cons #f #f)).
5a10: 09 20 20 20 20 28 65 6c 73 65 09 23 66 29 29 29 . (else.#f)))
5a20: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
5a30: 72 76 65 72 3a 67 65 74 2d 73 65 72 76 69 6e 66 rver:get-servinf
5a40: 6f 2d 64 69 72 20 61 72 65 61 70 61 74 68 29 0a o-dir areapath).
5a50: 20 20 28 6c 65 74 2a 20 28 28 73 70 61 74 68 20 (let* ((spath
5a60: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f (conc areapath"/
5a70: 2e 73 65 72 76 69 6e 66 6f 22 29 29 29 0a 20 20 .servinfo"))).
5a80: 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 (if (not (file
5a90: 2d 65 78 69 73 74 73 3f 20 73 70 61 74 68 29 29 -exists? spath))
5aa0: 0a 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 ..(create-direct
5ab0: 6f 72 79 20 73 70 61 74 68 20 23 74 29 29 0a 20 ory spath #t)).
5ac0: 20 20 20 73 70 61 74 68 29 29 0a 0a 28 64 65 66 spath))..(def
5ad0: 69 6e 65 20 28 73 65 72 76 65 72 3a 63 6c 65 61 ine (server:clea
5ae0: 6e 2d 75 70 2d 6f 6c 64 20 61 72 65 61 70 61 74 n-up-old areapat
5af0: 68 29 0a 20 20 3b 3b 20 61 6e 79 20 73 65 72 76 h). ;; any serv
5b00: 65 72 20 66 69 6c 65 20 74 68 61 74 20 68 61 73 er file that has
5b10: 20 6e 6f 74 20 62 65 65 6e 20 74 6f 75 63 68 65 not been touche
5b20: 64 20 69 6e 20 74 65 6e 20 6d 69 6e 75 74 65 73 d in ten minutes
5b30: 20 69 73 20 65 66 66 65 63 74 69 76 65 6c 79 20 is effectively
5b40: 64 65 61 64 0a 20 20 28 6c 65 74 2a 20 28 28 73 dead. (let* ((s
5b50: 66 69 6c 65 73 20 28 67 6c 6f 62 20 28 63 6f 6e files (glob (con
5b60: 63 20 28 73 65 72 76 65 72 3a 67 65 74 2d 73 65 c (server:get-se
5b70: 72 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 rvinfo-dir areap
5b80: 61 74 68 29 22 2f 2a 22 29 29 29 29 0a 20 20 20 ath)"/*")))).
5b90: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
5ba0: 28 6c 61 6d 62 64 61 20 28 73 66 69 6c 65 29 0a (lambda (sfile).
5bb0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6d (let* ((m
5bc0: 6f 64 74 69 6d 65 20 28 68 61 6e 64 6c 65 2d 65 odtime (handle-e
5bd0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 20 20 xceptions....
5be0: 65 78 6e 0a 09 09 09 20 28 62 65 67 69 6e 0a 09 exn.... (begin..
5bf0: 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
5c00: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
5c10: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
5c20: 20 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 6d failed to get m
5c30: 6f 64 69 66 69 63 61 74 69 6f 6e 20 66 69 6c 65 odification file
5c40: 20 66 6f 72 20 22 73 66 69 6c 65 29 0a 09 09 09 for "sfile)....
5c50: 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (current-seco
5c60: 6e 64 73 29 29 0a 09 09 09 20 28 66 69 6c 65 2d nds)).... (file-
5c70: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
5c80: 65 20 73 66 69 6c 65 29 29 29 29 0a 09 20 28 69 e sfile)))).. (i
5c90: 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 f (and (number?
5ca0: 6d 6f 64 74 69 6d 65 29 0a 09 09 20 20 28 3e 20 modtime)... (>
5cb0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
5cc0: 6e 64 73 29 20 6d 6f 64 74 69 6d 65 29 0a 09 09 nds) modtime)...
5cd0: 20 20 20 20 20 36 30 30 29 29 0a 09 20 20 20 20 600))..
5ce0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
5cf0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
5d00: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5d10: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 6f 75 6e * "WARNING: foun
5d20: 64 20 6f 6c 64 20 73 65 72 76 65 72 20 69 6e 66 d old server inf
5d30: 6f 20 66 69 6c 65 20 22 73 66 69 6c 65 22 2c 20 o file "sfile",
5d40: 72 65 6d 6f 76 69 6e 67 20 69 74 2e 22 29 0a 09 removing it.")..
5d50: 20 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 (handle-e
5d60: 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 65 xceptions... e
5d70: 78 6e 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 xn... (debug:pri
5d80: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
5d90: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
5da0: 3a 20 66 61 69 6c 65 64 20 74 6f 20 64 65 6c 65 : failed to dele
5db0: 74 65 20 6f 6c 64 20 73 65 72 76 65 72 20 69 6e te old server in
5dc0: 66 6f 20 66 69 6c 65 20 22 73 66 69 6c 65 29 0a fo file "sfile).
5dd0: 09 09 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 .. (delete-file
5de0: 73 66 69 6c 65 29 29 29 29 29 29 0a 20 20 20 20 sfile)))))).
5df0: 20 73 66 69 6c 65 73 29 29 29 0a 0a 3b 3b 20 77 sfiles)))..;; w
5e00: 6f 75 6c 64 20 6c 69 6b 65 20 74 6f 20 65 76 65 ould like to eve
5e10: 6e 74 75 61 6c 6c 79 20 67 65 74 20 72 69 64 20 ntually get rid
5e20: 6f 66 20 74 68 69 73 0a 3b 3b 0a 28 64 65 66 69 of this.;;.(defi
5e30: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f ne (common:on-ho
5e40: 6d 65 68 6f 73 74 3f 29 0a 20 20 28 69 66 20 28 mehost?). (if (
5e50: 65 71 3f 20 28 72 6d 74 3a 74 72 61 6e 73 70 6f eq? (rmt:transpo
5e60: 72 74 2d 6d 6f 64 65 29 20 27 68 74 74 70 29 0a rt-mode) 'http).
5e70: 20 20 20 20 20 20 28 73 65 72 76 65 72 3a 63 68 (server:ch
5e80: 6f 6f 73 65 2d 73 65 72 76 65 72 20 2a 74 6f 70 oose-server *top
5e90: 70 61 74 68 2a 20 27 68 6f 6d 65 3f 29 0a 20 20 path* 'home?).
5ea0: 20 20 20 20 23 74 29 29 20 3b 3b 20 74 68 65 72 #t)) ;; ther
5eb0: 65 20 69 73 20 6e 6f 20 68 6f 6d 65 68 6f 73 74 e is no homehost
5ec0: 20 66 6f 72 20 74 63 70 20 61 6e 64 20 6e 66 73 for tcp and nfs
5ed0: 20 69 73 20 61 6c 77 61 79 73 20 6f 6e 20 68 6f is always on ho
5ee0: 6d 65 20 73 6f 20 23 74 20 73 68 6f 75 6c 64 20 me so #t should
5ef0: 77 6f 72 6b 0a 0a 3b 3b 20 6b 69 6e 64 20 73 74 work..;; kind st
5f00: 61 72 74 20 75 70 20 6f 66 20 73 65 72 76 65 72 art up of server
5f10: 2c 20 77 61 69 74 20 62 65 66 6f 72 65 20 61 6c , wait before al
5f20: 6c 6f 77 69 6e 67 20 61 6e 6f 74 68 65 72 20 73 lowing another s
5f30: 65 72 76 65 72 20 66 6f 72 20 61 20 67 69 76 65 erver for a give
5f40: 6e 0a 3b 3b 20 61 72 65 61 20 74 6f 20 62 65 20 n.;; area to be
5f50: 6c 61 75 6e 63 68 65 64 0a 3b 3b 0a 28 64 65 66 launched.;;.(def
5f60: 69 6e 65 20 28 73 65 72 76 65 72 3a 6b 69 6e 64 ine (server:kind
5f70: 2d 72 75 6e 20 61 72 65 61 70 61 74 68 29 0a 20 -run areapath).
5f80: 20 3b 3b 20 6c 6f 6f 6b 20 66 6f 72 20 24 4d 54 ;; look for $MT
5f90: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 2f 6c _RUN_AREA_HOME/l
5fa0: 6f 67 73 2f 73 65 72 76 65 72 2d 73 74 61 72 74 ogs/server-start
5fb0: 2d 6c 61 73 74 0a 20 20 3b 3b 20 61 6e 64 20 77 -last. ;; and w
5fc0: 61 69 74 20 66 6f 72 20 69 74 20 74 6f 20 62 65 ait for it to be
5fd0: 20 61 74 20 6c 65 61 73 74 20 3c 73 65 72 76 65 at least <serve
5fe0: 72 20 69 64 6c 65 74 69 6d 65 3e 20 73 65 63 6f r idletime> seco
5ff0: 6e 64 73 20 6f 6c 64 0a 20 20 3b 3b 20 28 73 65 nds old. ;; (se
6000: 72 76 65 72 3a 77 61 69 74 2d 66 6f 72 2d 73 65 rver:wait-for-se
6010: 72 76 65 72 2d 73 74 61 72 74 2d 6c 61 73 74 2d rver-start-last-
6020: 66 6c 61 67 20 61 72 65 61 70 61 74 68 29 0a 20 flag areapath).
6030: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 20 20 (let loop ().
6040: 20 20 28 69 66 20 28 3e 20 28 61 6c 69 73 74 2d (if (> (alist-
6050: 72 65 66 20 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f ref 'adj-proc-lo
6060: 61 64 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e ad (common:get-n
6070: 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f ormalized-cpu-lo
6080: 61 64 20 23 66 29 29 20 32 29 0a 09 28 62 65 67 ad #f)) 2)..(beg
6090: 69 6e 0a 09 20 20 28 69 66 20 28 63 6f 6d 6d 6f in.. (if (commo
60a0: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
60b0: 74 20 33 30 20 22 6f 75 72 2d 68 6f 73 74 2d 6c t 30 "our-host-l
60c0: 6f 61 64 22 29 0a 09 20 20 20 20 20 20 28 64 65 oad").. (de
60d0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
60e0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
60f0: 57 41 52 4e 49 4e 47 3a 20 73 79 73 74 65 6d 20 WARNING: system
6100: 6c 6f 61 64 20 69 73 20 68 69 67 68 2c 20 77 61 load is high, wa
6110: 69 74 69 6e 67 20 74 6f 20 73 74 61 72 74 20 73 iting to start s
6120: 65 72 76 65 72 2e 22 29 29 0a 09 20 20 28 6c 6f erver.")).. (lo
6130: 6f 70 29 29 29 29 0a 20 20 28 69 66 20 28 3c 20 op)))). (if (<
6140: 28 73 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 (server:choose-s
6150: 65 72 76 65 72 20 61 72 65 61 70 61 74 68 20 27 erver areapath '
6160: 63 6f 75 6e 74 29 20 32 30 29 0a 20 20 20 20 20 count) 20).
6170: 20 28 73 65 72 76 65 72 3a 72 75 6e 20 61 72 65 (server:run are
6180: 61 70 61 74 68 29 29 0a 20 20 23 3b 28 69 66 20 apath)). #;(if
6190: 28 6e 6f 74 20 28 73 65 72 76 65 72 3a 63 68 65 (not (server:che
61a0: 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 ck-if-running ar
61b0: 65 61 70 61 74 68 29 29 20 3b 3b 20 77 68 79 20 eapath)) ;; why
61c0: 74 72 79 20 69 66 20 74 68 65 72 65 20 69 73 20 try if there is
61d0: 61 6c 72 65 61 64 79 20 61 20 73 65 72 76 65 72 already a server
61e0: 20 72 75 6e 6e 69 6e 67 3f 0a 20 20 20 20 20 20 running?.
61f0: 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 2d 66 69 6c (let* ((lock-fil
6200: 65 20 20 20 20 28 63 6f 6e 63 20 61 72 65 61 70 e (conc areap
6210: 61 74 68 20 22 2f 6c 6f 67 73 2f 73 65 72 76 65 ath "/logs/serve
6220: 72 2d 73 74 61 72 74 2e 6c 6f 63 6b 22 29 29 29 r-start.lock")))
6230: 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 72 74 2d ..(let* ((start-
6240: 66 6c 61 67 20 28 63 6f 6e 63 20 61 72 65 61 70 flag (conc areap
6250: 61 74 68 20 22 2f 6c 6f 67 73 2f 73 65 72 76 65 ath "/logs/serve
6260: 72 2d 73 74 61 72 74 2d 6c 61 73 74 22 29 29 29 r-start-last")))
6270: 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 .. (common:simp
6280: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 2d 61 6e 64 le-file-lock-and
6290: 2d 77 61 69 74 20 6c 6f 63 6b 2d 66 69 6c 65 20 -wait lock-file
62a0: 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 32 35 29 expire-time: 25)
62b0: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
62c0: 2d 69 6e 66 6f 20 20 32 20 2a 64 65 66 61 75 6c -info 2 *defaul
62d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 72 t-log-port* "ser
62e0: 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 3a 20 74 6f ver:kind-run: to
62f0: 75 63 68 69 6e 67 20 22 20 73 74 61 72 74 2d 66 uching " start-f
6300: 6c 61 67 29 0a 09 20 20 28 73 79 73 74 65 6d 20 lag).. (system
6310: 28 63 6f 6e 63 20 22 74 6f 75 63 68 20 22 20 73 (conc "touch " s
6320: 74 61 72 74 2d 66 6c 61 67 29 29 20 3b 3b 20 6c tart-flag)) ;; l
6330: 61 7a 79 20 62 75 74 20 73 61 66 65 0a 09 20 20 azy but safe..
6340: 28 73 65 72 76 65 72 3a 72 75 6e 20 61 72 65 61 (server:run area
6350: 70 61 74 68 29 0a 09 20 20 28 74 68 72 65 61 64 path).. (thread
6360: 2d 73 6c 65 65 70 21 20 32 30 29 20 3b 3b 20 64 -sleep! 20) ;; d
6370: 6f 6e 27 74 20 72 65 6c 65 61 73 65 20 74 68 65 on't release the
6380: 20 6c 6f 63 6b 20 66 6f 72 20 61 74 20 6c 65 61 lock for at lea
6390: 73 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 st a few seconds
63a0: 2e 20 41 6e 64 20 61 6c 6c 6f 77 20 74 69 6d 65 . And allow time
63b0: 20 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 20 for the server
63c0: 73 74 61 72 74 75 70 20 74 6f 20 67 65 74 20 74 startup to get t
63d0: 6f 20 22 53 45 52 56 45 52 20 53 54 41 52 54 45 o "SERVER STARTE
63e0: 44 22 2e 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 D"... (common:s
63f0: 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 imple-file-relea
6400: 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 2d 66 69 6c se-lock lock-fil
6410: 65 29 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 e))). (debu
6420: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
6430: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6440: 2a 20 22 46 6f 75 6e 64 20 73 65 72 76 65 72 20 * "Found server
6450: 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 2e already running.
6460: 20 4e 4f 54 20 74 72 79 69 6e 67 20 74 6f 20 73 NOT trying to s
6470: 74 61 72 74 20 61 6e 6f 74 68 65 72 2e 22 29 29 tart another."))
6480: 29 0a 0a 3b 3b 20 74 68 69 73 20 6f 6e 65 20 73 )..;; this one s
6490: 65 65 6d 73 20 74 6f 20 62 65 20 74 68 65 20 67 eems to be the g
64a0: 65 6e 65 72 61 6c 20 65 6e 74 72 79 20 70 6f 69 eneral entry poi
64b0: 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 nt.;;.(define (s
64c0: 65 72 76 65 72 3a 73 74 61 72 74 2d 61 6e 64 2d erver:start-and-
64d0: 77 61 69 74 20 61 72 65 61 70 61 74 68 20 23 21 wait areapath #!
64e0: 6b 65 79 20 28 74 69 6d 65 6f 75 74 20 36 30 29 key (timeout 60)
64f0: 29 0a 20 20 28 6c 65 74 20 28 28 67 69 76 65 2d ). (let ((give-
6500: 75 70 2d 74 69 6d 65 20 28 2b 20 28 63 75 72 72 up-time (+ (curr
6510: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 74 69 6d ent-seconds) tim
6520: 65 6f 75 74 29 29 29 0a 20 20 20 20 28 6c 65 74 eout))). (let
6530: 20 6c 6f 6f 70 20 28 28 73 65 72 76 65 72 2d 69 loop ((server-i
6540: 6e 66 6f 20 28 73 65 72 76 65 72 3a 63 68 65 63 nfo (server:chec
6550: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 k-if-running are
6560: 61 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 20 apath))..
6570: 28 74 72 79 2d 6e 75 6d 20 20 20 20 30 29 29 0a (try-num 0)).
6580: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 73 65 (if (or se
6590: 72 76 65 72 2d 69 6e 66 6f 0a 09 20 20 20 20 20 rver-info..
65a0: 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (> (current-sec
65b0: 6f 6e 64 73 29 20 67 69 76 65 2d 75 70 2d 74 69 onds) give-up-ti
65c0: 6d 65 29 29 20 3b 3b 20 73 65 72 76 65 72 2d 75 me)) ;; server-u
65d0: 72 6c 20 77 69 6c 6c 20 62 65 20 23 66 20 69 66 rl will be #f if
65e0: 20 6e 6f 20 73 65 72 76 65 72 20 61 76 61 69 6c no server avail
65f0: 61 62 6c 65 2e 0a 09 20 20 28 73 65 72 76 65 72 able... (server
6600: 3a 72 65 63 6f 72 64 2d 3e 75 72 6c 20 73 65 72 :record->url ser
6610: 76 65 72 2d 69 6e 66 6f 29 0a 09 20 20 28 6c 65 ver-info).. (le
6620: 74 2a 20 28 20 28 73 65 72 76 65 72 73 20 28 73 t* ( (servers (s
6630: 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 erver:choose-ser
6640: 76 65 72 20 61 72 65 61 70 61 74 68 20 27 61 6c ver areapath 'al
6650: 6c 2d 76 61 6c 69 64 29 29 0a 20 20 20 20 20 20 l-valid)).
6660: 20 20 20 20 20 20 20 20 20 20 28 6e 75 6d 2d 6f (num-o
6670: 6b 20 28 69 66 20 73 65 72 76 65 72 73 20 28 6c k (if servers (l
6680: 65 6e 67 74 68 20 28 73 65 72 76 65 72 3a 63 68 ength (server:ch
6690: 6f 6f 73 65 2d 73 65 72 76 65 72 20 61 72 65 61 oose-server area
66a0: 70 61 74 68 20 27 61 6c 6c 2d 76 61 6c 69 64 29 path 'all-valid)
66b0: 29 20 30 29 29 29 0a 09 20 20 20 20 28 69 66 20 ) 0))).. (if
66c0: 28 61 6e 64 20 28 3e 20 74 72 79 2d 6e 75 6d 20 (and (> try-num
66d0: 30 29 20 20 3b 3b 20 66 69 72 73 74 20 74 69 6d 0) ;; first tim
66e0: 65 20 74 68 72 6f 75 67 68 20 73 69 6d 70 6c 79 e through simply
66f0: 20 77 61 69 74 20 61 20 6c 69 74 74 6c 65 20 77 wait a little w
6700: 68 69 6c 65 20 74 68 65 6e 20 74 72 79 20 61 67 hile then try ag
6710: 61 69 6e 0a 09 09 20 20 20 20 20 28 3c 20 6e 75 ain... (< nu
6720: 6d 2d 6f 6b 20 31 29 29 20 20 3b 3b 20 69 66 20 m-ok 1)) ;; if
6730: 74 68 65 72 65 20 61 72 65 20 6e 6f 20 64 65 63 there are no dec
6740: 65 6e 74 20 63 61 6e 64 69 64 61 74 65 73 20 66 ent candidates f
6750: 6f 72 20 73 65 72 76 65 72 73 20 74 68 65 6e 20 or servers then
6760: 74 72 79 20 73 74 61 72 74 69 6e 67 20 61 20 6e try starting a n
6770: 65 77 20 6f 6e 65 0a 09 09 28 73 65 72 76 65 72 ew one...(server
6780: 3a 72 75 6e 20 61 72 65 61 70 61 74 68 29 29 0a :run areapath)).
6790: 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 . (thread-sle
67a0: 65 70 21 20 35 29 0a 09 20 20 20 20 28 6c 6f 6f ep! 5).. (loo
67b0: 70 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d p (server:check-
67c0: 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 if-running areap
67d0: 61 74 68 29 0a 09 09 20 20 28 2b 20 74 72 79 2d ath)... (+ try-
67e0: 6e 75 6d 20 31 29 29 29 29 29 29 29 0a 0a 28 64 num 1)))))))..(d
67f0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 efine (server:ge
6800: 74 2d 6e 75 6d 2d 73 65 72 76 65 72 73 20 23 21 t-num-servers #!
6810: 6b 65 79 20 28 6e 75 6d 73 65 72 76 65 72 73 20 key (numservers
6820: 32 29 29 0a 20 20 28 6c 65 74 20 28 28 6e 73 20 2)). (let ((ns
6830: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a (string->number.
6840: 09 20 20 20 20 20 28 6f 72 20 28 63 6f 6e 66 69 . (or (confi
6850: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
6860: 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 gdat* "server" "
6870: 6e 75 6d 73 65 72 76 65 72 73 22 29 20 22 6e 6f numservers") "no
6880: 74 61 6e 75 6d 62 65 72 22 29 29 29 29 0a 20 20 tanumber")))).
6890: 20 20 28 6f 72 20 6e 73 20 6e 75 6d 73 65 72 76 (or ns numserv
68a0: 65 72 73 29 29 29 0a 0a 3b 3b 20 6e 6f 20 6c 6f ers)))..;; no lo
68b0: 6e 67 65 72 20 63 61 72 65 20 69 66 20 6d 75 6c nger care if mul
68c0: 74 69 70 6c 65 20 73 65 72 76 65 72 73 20 61 72 tiple servers ar
68d0: 65 20 73 74 61 72 74 65 64 20 62 79 20 61 63 63 e started by acc
68e0: 69 64 65 6e 74 2e 20 6f 6c 64 65 72 20 73 65 72 ident. older ser
68f0: 76 65 72 73 20 77 69 6c 6c 20 64 72 6f 70 20 6f vers will drop o
6900: 66 66 20 69 6e 20 74 69 6d 65 2e 0a 3b 3b 0a 28 ff in time..;;.(
6910: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 63 define (server:c
6920: 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 heck-if-running
6930: 61 72 65 61 70 61 74 68 29 20 3b 3b 20 20 23 21 areapath) ;; #!
6940: 6b 65 79 20 28 6e 75 6d 73 65 72 76 65 72 73 20 key (numservers
6950: 22 32 22 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 "2")). (let* ((
6960: 6e 73 20 20 20 20 20 20 20 20 20 20 20 20 28 73 ns (s
6970: 65 72 76 65 72 3a 67 65 74 2d 6e 75 6d 2d 73 65 erver:get-num-se
6980: 72 76 65 72 73 29 29 20 3b 3b 20 67 65 74 20 74 rvers)) ;; get t
6990: 68 65 20 73 65 74 74 69 6e 67 20 74 68 65 20 66 he setting the f
69a0: 6f 72 20 6d 61 78 69 6d 75 6d 20 6e 75 6d 62 65 or maximum numbe
69b0: 72 20 6f 66 20 73 65 72 76 65 72 73 20 61 6c 6c r of servers all
69c0: 6f 77 65 64 0a 09 20 28 73 65 72 76 65 72 73 20 owed.. (servers
69d0: 20 20 20 20 20 20 28 73 65 72 76 65 72 3a 63 68 (server:ch
69e0: 6f 6f 73 65 2d 73 65 72 76 65 72 20 61 72 65 61 oose-server area
69f0: 70 61 74 68 20 27 62 65 73 74 2d 74 65 6e 29 29 path 'best-ten))
6a00: 29 20 3b 3b 20 28 73 65 72 76 65 72 3a 67 65 74 ) ;; (server:get
6a10: 2d 62 65 73 74 20 28 73 65 72 76 65 72 3a 67 65 -best (server:ge
6a20: 74 2d 6c 69 73 74 20 61 72 65 61 70 61 74 68 29 t-list areapath)
6a30: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 ))). (if (or
6a40: 28 61 6e 64 20 73 65 72 76 65 72 73 0a 09 09 20 (and servers...
6a50: 28 6e 75 6c 6c 3f 20 73 65 72 76 65 72 73 29 29 (null? servers))
6a60: 0a 09 20 20 20 20 28 6e 6f 74 20 73 65 72 76 65 .. (not serve
6a70: 72 73 29 29 0a 09 20 20 20 20 3b 3b 20 28 61 6e rs)).. ;; (an
6a80: 64 20 28 6c 69 73 74 3f 20 73 65 72 76 65 72 73 d (list? servers
6a90: 29 0a 09 20 20 20 20 3b 3b 09 20 28 3c 20 28 6c ).. ;;. (< (l
6aa0: 65 6e 67 74 68 20 73 65 72 76 65 72 73 29 20 28 ength servers) (
6ab0: 2b 20 31 20 28 72 61 6e 64 6f 6d 20 6e 73 29 29 + 1 (random ns))
6ac0: 29 29 29 20 3b 3b 20 73 6f 6d 65 77 68 65 72 65 ))) ;; somewhere
6ad0: 20 62 65 74 77 65 65 6e 20 31 20 61 6e 64 20 6e between 1 and n
6ae0: 75 6d 73 65 72 76 65 72 73 0a 20 20 20 20 20 20 umservers.
6af0: 20 20 23 66 0a 20 20 20 20 20 20 20 20 28 6c 65 #f. (le
6b00: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
6b10: 72 20 73 65 72 76 65 72 73 29 29 0a 20 20 20 20 r servers)).
6b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6b30: 74 61 6c 20 28 63 64 72 20 73 65 72 76 65 72 73 tal (cdr servers
6b40: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c ))). (l
6b50: 65 74 20 28 28 72 65 73 20 28 73 65 72 76 65 72 et ((res (server
6b60: 3a 63 68 65 63 6b 2d 73 65 72 76 65 72 20 68 65 :check-server he
6b70: 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 d))).
6b80: 20 28 69 66 20 72 65 73 0a 20 20 20 20 20 20 20 (if res.
6b90: 20 20 20 20 20 20 20 20 20 68 65 64 0a 20 20 20 hed.
6ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
6bb0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 20 20 20 (null? tal).
6bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6bd0: 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f.
6be0: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 (loop (c
6bf0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
6c00: 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 70 69 6e ))))))))..;; pin
6c10: 67 20 74 68 65 20 67 69 76 65 6e 20 73 65 72 76 g the given serv
6c20: 65 72 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 er.;;.(define (s
6c30: 65 72 76 65 72 3a 63 68 65 63 6b 2d 73 65 72 76 erver:check-serv
6c40: 65 72 20 73 65 72 76 65 72 2d 72 65 63 6f 72 64 er server-record
6c50: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 ). (let* ((serv
6c60: 65 72 2d 75 72 6c 20 28 73 65 72 76 65 72 3a 72 er-url (server:r
6c70: 65 63 6f 72 64 2d 3e 75 72 6c 20 73 65 72 76 65 ecord->url serve
6c80: 72 2d 72 65 63 6f 72 64 29 29 0a 20 20 20 20 20 r-record)).
6c90: 20 20 20 20 28 73 65 72 76 65 72 2d 69 64 20 20 (server-id
6ca0: 28 73 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e (server:record->
6cb0: 69 64 20 73 65 72 76 65 72 2d 72 65 63 6f 72 64 id server-record
6cc0: 29 29 20 0a 20 20 20 20 20 20 20 20 20 28 72 65 )) . (re
6cd0: 73 20 20 20 20 20 20 20 20 28 73 65 72 76 65 72 s (server
6ce0: 3a 70 69 6e 67 20 73 65 72 76 65 72 2d 75 72 6c :ping server-url
6cf0: 20 73 65 72 76 65 72 2d 69 64 29 29 29 0a 20 20 server-id))).
6d00: 20 20 28 69 66 20 72 65 73 0a 20 20 20 20 20 20 (if res.
6d10: 20 20 73 65 72 76 65 72 2d 75 72 6c 0a 09 23 66 server-url..#f
6d20: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
6d30: 72 76 65 72 3a 6b 69 6c 6c 20 73 65 72 76 72 29 rver:kill servr)
6d40: 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
6d50: 74 69 6f 6e 73 0a 20 20 20 20 65 78 6e 0a 20 20 tions. exn.
6d60: 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 (begin .
6d70: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6d80: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
6d90: 2d 70 6f 72 74 2a 20 20 22 55 6e 61 62 6c 65 20 -port* "Unable
6da0: 74 6f 20 67 65 74 20 68 6f 73 74 20 61 6e 64 2f to get host and/
6db0: 6f 72 20 70 6f 72 74 20 66 72 6f 6d 20 22 20 73 or port from " s
6dc0: 65 72 76 72 20 22 2c 20 65 78 6e 3d 22 20 65 78 ervr ", exn=" ex
6dd0: 6e 29 20 20 20 20 20 0a 20 20 20 20 23 66 29 0a n) . #f).
6de0: 20 20 28 6d 61 74 63 68 2d 6c 65 74 20 28 28 28 (match-let (((
6df0: 68 6f 73 74 6e 61 6d 65 20 70 6f 72 74 20 73 74 hostname port st
6e00: 61 72 74 2d 74 69 6d 65 20 73 65 72 76 65 72 2d art-time server-
6e10: 69 64 20 70 69 64 29 0a 09 20 20 20 20 20 20 20 id pid)..
6e20: 73 65 72 76 72 29 29 0a 20 20 20 20 28 74 61 73 servr)). (tas
6e30: 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 20 68 ks:kill-server h
6e40: 6f 73 74 6e 61 6d 65 20 70 69 64 29 29 29 29 0a ostname pid)))).
6e50: 0a 3b 3b 20 63 61 6c 6c 65 64 20 69 6e 20 6d 65 .;; called in me
6e60: 67 61 74 65 73 74 2e 73 63 6d 2c 20 68 6f 73 74 gatest.scm, host
6e70: 2d 70 6f 72 74 20 69 73 20 73 74 72 69 6e 67 20 -port is string
6e80: 68 6f 73 74 6e 61 6d 65 3a 70 6f 72 74 0a 3b 3b hostname:port.;;
6e90: 0a 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 .;; NOTE: This i
6ea0: 73 20 4e 4f 54 20 63 61 6c 6c 65 64 20 64 69 72 s NOT called dir
6eb0: 65 63 74 6c 79 20 66 72 6f 6d 20 63 6c 69 65 6e ectly from clien
6ec0: 74 73 20 61 73 20 6e 6f 74 20 61 6c 6c 20 74 72 ts as not all tr
6ed0: 61 6e 73 70 6f 72 74 73 20 73 75 70 70 6f 72 74 ansports support
6ee0: 20 61 20 63 6c 69 65 6e 74 20 72 75 6e 6e 69 6e a client runnin
6ef0: 67 0a 3b 3b 20 20 20 20 20 20 20 69 6e 20 74 68 g.;; in th
6f00: 65 20 73 61 6d 65 20 70 72 6f 63 65 73 73 20 61 e same process a
6f10: 73 20 74 68 65 20 73 65 72 76 65 72 2e 0a 3b 3b s the server..;;
6f20: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
6f30: 3a 70 69 6e 67 20 68 6f 73 74 3a 70 6f 72 74 20 :ping host:port
6f40: 73 65 72 76 65 72 2d 69 64 20 23 21 6b 65 79 20 server-id #!key
6f50: 28 64 6f 2d 65 78 69 74 20 23 66 29 29 0a 20 20 (do-exit #f)).
6f60: 28 6c 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f 72 (let* ((host-por
6f70: 74 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 28 t (cond... (
6f80: 28 73 74 72 69 6e 67 3f 20 68 6f 73 74 3a 70 6f (string? host:po
6f90: 72 74 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 rt)... (let
6fa0: 20 28 28 73 6c 73 74 20 28 73 74 72 69 6e 67 2d ((slst (string-
6fb0: 73 70 6c 69 74 20 20 20 68 6f 73 74 3a 70 6f 72 split host:por
6fc0: 74 20 22 3a 22 29 29 29 0a 09 09 09 28 69 66 20 t ":")))....(if
6fd0: 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 73 6c 73 (eq? (length sls
6fe0: 74 29 20 32 29 0a 09 09 09 20 20 20 20 28 6c 69 t) 2).... (li
6ff0: 73 74 20 28 63 61 72 20 73 6c 73 74 29 28 73 74 st (car slst)(st
7000: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 ring->number (ca
7010: 64 72 20 73 6c 73 74 29 29 29 0a 09 09 09 20 20 dr slst)))....
7020: 20 20 23 66 29 29 29 0a 09 09 20 20 20 20 20 28 #f)))... (
7030: 65 6c 73 65 0a 09 09 20 20 20 20 20 20 23 66 29 else... #f)
7040: 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 ))). (cond.
7050: 20 20 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 ((and (list?
7060: 68 6f 73 74 2d 70 6f 72 74 29 0a 09 20 20 20 28 host-port).. (
7070: 65 71 3f 20 28 6c 65 6e 67 74 68 20 68 6f 73 74 eq? (length host
7080: 2d 70 6f 72 74 29 20 32 29 29 0a 20 20 20 20 20 -port) 2)).
7090: 20 28 6c 65 74 2a 20 28 28 6d 79 72 75 6e 72 65 (let* ((myrunre
70a0: 6d 6f 74 65 20 28 6d 61 6b 65 2d 61 6e 64 2d 69 mote (make-and-i
70b0: 6e 69 74 2d 72 65 6d 6f 74 65 20 2a 74 6f 70 70 nit-remote *topp
70c0: 61 74 68 2a 29 29 0a 09 20 20 20 20 20 28 69 66 ath*)).. (if
70d0: 61 63 65 20 20 20 20 20 20 20 28 63 61 72 20 68 ace (car h
70e0: 6f 73 74 2d 70 6f 72 74 29 29 0a 09 20 20 20 20 ost-port))..
70f0: 20 28 70 6f 72 74 20 20 20 20 20 20 20 20 28 63 (port (c
7100: 61 64 72 20 68 6f 73 74 2d 70 6f 72 74 29 29 0a adr host-port)).
7110: 09 20 20 20 20 20 28 73 65 72 76 65 72 2d 64 61 . (server-da
7120: 74 20 20 28 63 6c 69 65 6e 74 3a 63 6f 6e 6e 65 t (client:conne
7130: 63 74 20 69 66 61 63 65 20 70 6f 72 74 20 73 65 ct iface port se
7140: 72 76 65 72 2d 69 64 20 6d 79 72 75 6e 72 65 6d rver-id myrunrem
7150: 6f 74 65 29 29 0a 09 20 20 20 20 20 28 6c 6f 67 ote)).. (log
7160: 69 6e 2d 72 65 73 20 20 20 28 72 6d 74 3a 6c 6f in-res (rmt:lo
7170: 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 gin-no-auto-clie
7180: 6e 74 2d 73 65 74 75 70 20 6d 79 72 75 6e 72 65 nt-setup myrunre
7190: 6d 6f 74 65 29 29 29 0a 09 28 68 74 74 70 2d 74 mote)))..(http-t
71a0: 72 61 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 ransport:close-c
71b0: 6f 6e 6e 65 63 74 69 6f 6e 73 20 6d 79 72 75 6e onnections myrun
71c0: 72 65 6d 6f 74 65 29 0a 09 28 69 66 20 28 61 6e remote)..(if (an
71d0: 64 20 28 6c 69 73 74 3f 20 6c 6f 67 69 6e 2d 72 d (list? login-r
71e0: 65 73 29 0a 09 09 20 28 63 61 72 20 6c 6f 67 69 es)... (car logi
71f0: 6e 2d 72 65 73 29 29 0a 09 20 20 20 20 28 62 65 n-res)).. (be
7200: 67 69 6e 0a 09 20 20 20 20 20 20 3b 3b 20 28 70 gin.. ;; (p
7210: 72 69 6e 74 20 22 4c 4f 47 49 4e 5f 4f 4b 22 29 rint "LOGIN_OK")
7220: 0a 09 20 20 20 20 20 20 28 69 66 20 64 6f 2d 65 .. (if do-e
7230: 78 69 74 20 28 65 78 69 74 20 30 29 29 0a 09 20 xit (exit 0))..
7240: 20 20 20 20 20 23 74 29 0a 09 20 20 20 20 28 62 #t).. (b
7250: 65 67 69 6e 0a 09 20 20 20 20 20 20 3b 3b 20 28 egin.. ;; (
7260: 70 72 69 6e 74 20 22 4c 4f 47 49 4e 5f 46 41 49 print "LOGIN_FAI
7270: 4c 45 44 22 29 0a 09 20 20 20 20 20 20 28 69 66 LED").. (if
7280: 20 64 6f 2d 65 78 69 74 20 28 65 78 69 74 20 31 do-exit (exit 1
7290: 29 29 0a 09 20 20 20 20 20 20 23 66 29 29 29 29 )).. #f))))
72a0: 0a 20 20 20 20 20 28 65 6c 73 65 20 0a 20 20 20 . (else .
72b0: 20 20 20 28 69 66 20 68 6f 73 74 3a 70 6f 72 74 (if host:port
72c0: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
72d0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
72e0: 70 6f 72 74 2a 20 20 22 45 52 52 4f 52 3a 20 62 port* "ERROR: b
72f0: 61 64 20 68 6f 73 74 3a 70 6f 72 74 20 22 68 6f ad host:port "ho
7300: 73 74 3a 70 6f 72 74 29 29 0a 20 20 20 20 20 20 st:port)).
7310: 28 69 66 20 64 6f 2d 65 78 69 74 0a 09 20 20 28 (if do-exit.. (
7320: 65 78 69 74 20 31 29 0a 09 20 20 23 66 29 29 29 exit 1).. #f)))
7330: 29 29 0a 0a 3b 3b 20 72 75 6e 20 70 69 6e 67 20 ))..;; run ping
7340: 69 6e 20 73 65 70 61 72 61 74 65 20 70 72 6f 63 in separate proc
7350: 65 73 73 2c 20 73 61 66 65 73 74 20 77 61 79 20 ess, safest way
7360: 69 6e 20 73 6f 6d 65 20 63 61 73 65 73 0a 3b 3b in some cases.;;
7370: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
7380: 3a 70 69 6e 67 2d 73 65 72 76 65 72 20 69 66 61 :ping-server ifa
7390: 63 65 70 6f 72 74 29 0a 20 20 28 77 69 74 68 2d ceport). (with-
73a0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
73b0: 0a 20 20 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f . (conc (commo
73c0: 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 n:get-megatest-e
73d0: 78 65 29 20 22 20 2d 70 69 6e 67 20 22 20 69 66 xe) " -ping " if
73e0: 61 63 65 70 6f 72 74 29 0a 20 20 20 28 6c 61 6d aceport). (lam
73f0: 62 64 61 20 28 29 0a 20 20 20 20 20 28 6c 65 74 bda (). (let
7400: 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 loop ((inl (rea
7410: 64 2d 6c 69 6e 65 29 29 0a 09 09 28 72 65 73 20 d-line))...(res
7420: 22 4e 4f 52 45 50 4c 59 22 29 29 0a 20 20 20 20 "NOREPLY")).
7430: 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 (if (eof-obje
7440: 63 74 3f 20 69 6e 6c 29 0a 09 20 20 20 28 63 61 ct? inl).. (ca
7450: 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 se (string->symb
7460: 6f 6c 20 72 65 73 29 0a 09 20 20 20 20 20 28 28 ol res).. ((
7470: 4e 4f 52 45 50 4c 59 29 20 20 23 66 29 0a 09 20 NOREPLY) #f)..
7480: 20 20 20 20 28 28 4c 4f 47 49 4e 5f 4f 4b 29 20 ((LOGIN_OK)
7490: 23 74 29 0a 09 20 20 20 20 20 28 65 6c 73 65 20 #t).. (else
74a0: 20 20 20 20 20 20 23 66 29 29 0a 09 20 20 20 28 #f)).. (
74b0: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
74c0: 20 69 6e 6c 29 29 29 29 29 29 0a 0a 3b 3b 20 4e inl))))))..;; N
74d0: 4f 54 20 55 53 45 44 20 28 77 65 6c 6c 2c 20 6f OT USED (well, o
74e0: 6b 2c 20 72 65 66 65 72 65 6e 63 65 20 69 6e 20 k, reference in
74f0: 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 20 62 75 rpc-transport bu
7500: 74 20 6f 74 68 65 72 77 69 73 65 20 6e 6f 74 20 t otherwise not
7510: 75 73 65 64 29 2e 0a 3b 3b 0a 28 64 65 66 69 6e used)..;;.(defin
7520: 65 20 28 73 65 72 76 65 72 3a 6c 6f 67 69 6e 20 e (server:login
7530: 74 6f 70 70 61 74 68 29 0a 20 20 28 6c 61 6d 62 toppath). (lamb
7540: 64 61 20 28 74 6f 70 70 61 74 68 29 0a 20 20 20 da (toppath).
7550: 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d (set! *db-last-
7560: 61 63 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 access* (current
7570: 2d 73 65 63 6f 6e 64 73 29 29 20 3b 3b 20 6d 69 -seconds)) ;; mi
7580: 67 68 74 20 6e 6f 74 20 62 65 20 6e 65 65 64 65 ght not be neede
7590: 64 2e 0a 20 20 20 20 28 69 66 20 28 65 71 75 61 d.. (if (equa
75a0: 6c 3f 20 2a 74 6f 70 70 61 74 68 2a 20 74 6f 70 l? *toppath* top
75b0: 70 61 74 68 29 0a 09 23 74 0a 09 23 66 29 29 29 path)..#t..#f)))
75c0: 0a 0a 3b 3b 20 74 69 6d 65 6f 75 74 20 69 73 20 ..;; timeout is
75d0: 68 6d 73 20 73 74 72 69 6e 67 3a 20 31 68 20 35 hms string: 1h 5
75e0: 6d 20 33 73 2c 20 64 65 66 61 75 6c 74 20 69 73 m 3s, default is
75f0: 20 31 20 6d 69 6e 75 74 65 0a 3b 3b 20 54 68 69 1 minute.;; Thi
7600: 73 20 69 73 20 63 75 72 72 65 6e 74 6c 79 20 62 s is currently b
7610: 72 6f 6b 65 6e 2e 20 4a 75 73 74 20 75 73 65 20 roken. Just use
7620: 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 68 6f the number of ho
7630: 75 72 73 20 77 69 74 68 20 6e 6f 20 75 6e 69 74 urs with no unit
7640: 2e 0a 3b 3b 20 44 65 66 61 75 6c 74 20 69 73 20 ..;; Default is
7650: 36 30 20 73 65 63 6f 6e 64 73 2e 0a 3b 3b 0a 28 60 seconds..;;.(
7660: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 65 define (server:e
7670: 78 70 69 72 61 74 69 6f 6e 2d 74 69 6d 65 6f 75 xpiration-timeou
7680: 74 29 0a 20 20 28 6c 65 74 20 28 28 74 6d 6f 20 t). (let ((tmo
7690: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
76a0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 *configdat* "ser
76b0: 76 65 72 22 20 22 74 69 6d 65 6f 75 74 22 29 29 ver" "timeout"))
76c0: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 ). (if (and (
76d0: 73 74 72 69 6e 67 3f 20 74 6d 6f 29 0a 09 20 20 string? tmo)..
76e0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 (common:hms-s
76f0: 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 74 tring->seconds t
7700: 6d 6f 29 29 20 3b 3b 20 42 55 47 3a 20 68 6d 73 mo)) ;; BUG: hms
7710: 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 -string->seconds
7720: 20 69 73 20 62 72 6f 6b 65 6e 2c 20 69 66 20 67 is broken, if g
7730: 69 76 65 6e 20 22 31 30 22 20 72 65 74 75 72 6e iven "10" return
7740: 73 20 30 2e 20 41 6c 73 6f 2c 20 69 74 20 64 6f s 0. Also, it do
7750: 65 73 6e 27 74 20 62 65 6c 6f 6e 67 20 69 6e 20 esn't belong in
7760: 74 68 69 73 20 6c 6f 67 69 63 20 75 6e 6c 65 73 this logic unles
7770: 73 20 74 68 65 20 73 74 72 69 6e 67 2d 3e 6e 75 s the string->nu
7780: 6d 62 65 72 20 69 73 20 63 68 61 6e 67 65 64 20 mber is changed
7790: 62 65 6c 6f 77 0a 20 20 20 20 20 20 20 20 28 2a below. (*
77a0: 20 33 36 30 30 20 28 73 74 72 69 6e 67 2d 3e 6e 3600 (string->n
77b0: 75 6d 62 65 72 20 74 6d 6f 29 29 0a 09 36 30 30 umber tmo))..600
77c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
77d0: 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 rver:get-best-gu
77e0: 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 ess-address host
77f0: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 name). (let ((r
7800: 65 73 20 23 66 29 29 0a 20 20 20 20 28 66 6f 72 es #f)). (for
7810: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
7820: 62 64 61 20 28 61 64 72 29 0a 20 20 20 20 20 20 bda (adr).
7830: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 (if (not (eq? (
7840: 75 38 76 65 63 74 6f 72 2d 72 65 66 20 61 64 72 u8vector-ref adr
7850: 20 30 29 20 31 32 37 29 29 0a 09 20 20 20 28 73 0) 127)).. (s
7860: 65 74 21 20 72 65 73 20 61 64 72 29 29 29 0a 20 et! res adr))).
7870: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
7880: 73 20 63 61 6e 20 66 61 69 6c 20 77 68 65 6e 20 s can fail when
7890: 74 68 65 72 65 20 69 73 20 6e 6f 20 6d 65 6e 74 there is no ment
78a0: 69 6f 6e 20 6f 66 20 74 68 65 20 68 6f 73 74 20 ion of the host
78b0: 69 6e 20 2f 65 74 63 2f 68 6f 73 74 73 2e 20 46 in /etc/hosts. F
78c0: 49 58 4d 45 0a 20 20 20 20 20 28 76 65 63 74 6f IXME. (vecto
78d0: 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 69 6e 66 r->list (hostinf
78e0: 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 o-addresses (hos
78f0: 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 tname->hostinfo
7900: 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 20 hostname)))).
7910: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7920: 65 72 73 65 20 0a 20 20 20 20 20 28 6d 61 70 20 erse . (map
7930: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 0a 09 number->string..
7940: 20 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 (u8vector->lis
7950: 74 0a 09 20 20 20 28 69 66 20 72 65 73 20 72 65 t.. (if res re
7960: 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 s (hostname->ip
7970: 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 22 2e 22 hostname)))) "."
7980: 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 )))..;; (define
7990: 73 65 72 76 65 72 3a 73 79 6e 63 2d 6c 6f 63 6b server:sync-lock
79a0: 2d 74 6f 6b 65 6e 20 22 53 45 52 56 45 52 5f 53 -token "SERVER_S
79b0: 59 4e 43 5f 4c 4f 43 4b 22 29 0a 3b 3b 20 28 64 YNC_LOCK").;; (d
79c0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 72 65 efine (server:re
79d0: 6c 65 61 73 65 2d 73 79 6e 63 2d 6c 6f 63 6b 29 lease-sync-lock)
79e0: 0a 3b 3b 20 20 20 28 64 62 3a 6e 6f 2d 73 79 6e .;; (db:no-syn
79f0: 63 2d 64 65 6c 21 20 2a 6e 6f 2d 73 79 6e 63 2d c-del! *no-sync-
7a00: 64 62 2a 20 73 65 72 76 65 72 3a 73 79 6e 63 2d db* server:sync-
7a10: 6c 6f 63 6b 2d 74 6f 6b 65 6e 29 29 0a 3b 3b 20 lock-token)).;;
7a20: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
7a30: 68 61 76 65 2d 73 79 6e 63 2d 6c 6f 63 6b 3f 29 have-sync-lock?)
7a40: 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 68 61 .;; (let* ((ha
7a50: 76 65 2d 6c 6f 63 6b 2d 70 61 69 72 20 28 64 62 ve-lock-pair (db
7a60: 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 :no-sync-get-loc
7a70: 6b 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 73 k *no-sync-db* s
7a80: 65 72 76 65 72 3a 73 79 6e 63 2d 6c 6f 63 6b 2d erver:sync-lock-
7a90: 74 6f 6b 65 6e 29 29 0a 3b 3b 20 20 20 20 20 20 token)).;;
7aa0: 20 20 20 20 28 68 61 76 65 2d 6c 6f 63 6b 3f 20 (have-lock?
7ab0: 20 20 20 20 28 63 61 72 20 68 61 76 65 2d 6c 6f (car have-lo
7ac0: 63 6b 2d 70 61 69 72 29 29 0a 3b 3b 20 20 20 20 ck-pair)).;;
7ad0: 20 20 20 20 20 20 28 6c 6f 63 6b 2d 74 69 6d 65 (lock-time
7ae0: 20 20 20 20 20 20 28 63 64 72 20 68 61 76 65 2d (cdr have-
7af0: 6c 6f 63 6b 2d 70 61 69 72 29 29 0a 3b 3b 20 20 lock-pair)).;;
7b00: 20 20 20 20 20 20 20 20 28 6c 6f 63 6b 2d 61 67 (lock-ag
7b10: 65 20 20 20 20 20 20 20 28 2d 20 28 63 75 72 72 e (- (curr
7b20: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 6f 63 ent-seconds) loc
7b30: 6b 2d 74 69 6d 65 29 29 29 0a 3b 3b 20 20 20 20 k-time))).;;
7b40: 20 28 63 6f 6e 64 0a 3b 3b 20 20 20 20 20 20 28 (cond.;; (
7b50: 68 61 76 65 2d 6c 6f 63 6b 3f 20 23 74 29 0a 3b have-lock? #t).;
7b60: 3b 20 20 20 20 20 20 28 28 3e 6c 6f 63 6b 2d 61 ; ((>lock-a
7b70: 67 65 0a 3b 3b 20 20 20 20 20 20 20 20 28 2a 20 ge.;; (*
7b80: 33 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 3 (configf:looku
7b90: 70 2d 6e 75 6d 62 65 72 20 2a 63 6f 6e 66 69 67 p-number *config
7ba0: 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 6d dat* "server" "m
7bb0: 69 6e 69 6d 75 6d 2d 69 6e 74 65 72 73 79 6e 63 inimum-intersync
7bc0: 2d 64 65 6c 61 79 22 20 64 65 66 61 75 6c 74 3a -delay" default:
7bd0: 20 31 38 30 29 29 29 0a 3b 3b 20 20 20 20 20 20 180))).;;
7be0: 20 28 73 65 72 76 65 72 3a 72 65 6c 65 61 73 65 (server:release
7bf0: 2d 73 79 6e 63 2d 6c 6f 63 6b 29 0a 3b 3b 20 20 -sync-lock).;;
7c00: 20 20 20 20 20 28 73 65 72 76 65 72 3a 68 61 76 (server:hav
7c10: 65 2d 73 79 6e 63 2d 6c 6f 63 6b 3f 29 29 0a 3b e-sync-lock?)).;
7c20: 3b 20 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 ; (else #f)
7c30: 29 29 29 0a 0a 3b 3b 20 6d 6f 76 69 6e 67 20 74 )))..;; moving t
7c40: 68 69 73 20 68 65 72 65 20 61 73 20 69 74 20 6e his here as it n
7c50: 65 65 64 73 20 61 63 63 65 73 73 20 74 6f 20 64 eeds access to d
7c60: 62 20 61 6e 64 20 63 61 6e 6e 6f 74 20 62 65 20 b and cannot be
7c70: 69 6e 20 63 6f 6d 6d 6f 6e 2e 0a 3b 3b 0a 0a 28 in common..;;..(
7c80: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 define (server:g
7c90: 65 74 2d 62 72 75 74 65 66 6f 72 63 65 2d 73 79 et-bruteforce-sy
7ca0: 6e 63 65 72 20 64 62 73 74 72 75 63 74 20 23 21 ncer dbstruct #!
7cb0: 6b 65 79 20 28 66 6f 72 6b 2d 74 6f 2d 62 61 63 key (fork-to-bac
7cc0: 6b 67 72 6f 75 6e 64 20 23 66 29 20 28 70 65 72 kground #f) (per
7cd0: 73 69 73 74 2d 75 6e 74 69 6c 2d 73 79 6e 63 20 sist-until-sync
7ce0: 23 66 29 29 0a 20 20 28 64 65 62 75 67 3a 70 72 #f)). (debug:pr
7cf0: 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 62 72 int "WARNING: br
7d00: 75 74 65 66 6f 72 63 65 2d 73 79 6e 63 65 72 20 uteforce-syncer
7d10: 69 73 20 63 61 6c 6c 65 64 20 62 75 74 20 68 61 is called but ha
7d20: 73 20 62 65 65 6e 20 64 69 73 61 62 6c 65 64 21 s been disabled!
7d30: 22 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 29 0a "). (lambda ().
7d40: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7d50: 20 22 57 41 52 4e 49 4e 47 3a 20 62 72 75 74 65 "WARNING: brute
7d60: 66 6f 72 63 65 2d 73 79 6e 63 65 72 20 69 73 20 force-syncer is
7d70: 63 61 6c 6c 65 64 20 62 75 74 20 68 61 73 20 62 called but has b
7d80: 65 65 6e 20 64 69 73 61 62 6c 65 64 21 22 29 29 een disabled!"))
7d90: 0a 20 20 23 3b 28 6c 65 74 2a 20 28 28 73 71 6c . #;(let* ((sql
7da0: 69 74 65 2d 65 78 65 20 20 20 28 6f 72 20 28 67 ite-exe (or (g
7db0: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
7dc0: 61 72 69 61 62 6c 65 20 22 4d 54 5f 53 51 4c 49 ariable "MT_SQLI
7dd0: 54 45 33 5f 45 58 45 22 29 29 29 20 3b 3b 20 64 TE3_EXE"))) ;; d
7de0: 65 66 69 6e 65 64 20 69 6e 20 63 66 67 2e 73 68 efined in cfg.sh
7df0: 0a 20 20 20 20 20 20 20 20 20 28 73 79 6e 63 2d . (sync-
7e00: 6c 6f 67 20 20 20 20 20 28 6f 72 20 28 61 72 67 log (or (arg
7e10: 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 79 6e 63 s:get-arg "-sync
7e20: 2d 6c 6f 67 22 29 20 28 63 6f 6e 63 20 2a 74 6f -log") (conc *to
7e30: 70 70 61 74 68 2a 20 22 2f 6c 6f 67 73 2f 73 79 ppath* "/logs/sy
7e40: 6e 63 2d 22 20 28 63 75 72 72 65 6e 74 2d 70 72 nc-" (current-pr
7e50: 6f 63 65 73 73 2d 69 64 29 20 22 2d 22 20 28 67 ocess-id) "-" (g
7e60: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2e et-host-name) ".
7e70: 6c 6f 67 22 29 29 29 0a 09 20 28 74 6d 70 2d 61 log"))).. (tmp-a
7e80: 72 65 61 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a rea (common:
7e90: 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 get-db-tmp-area)
7ea0: 29 0a 09 20 28 74 6d 70 2d 64 62 20 20 20 20 20 ).. (tmp-db
7eb0: 20 20 28 63 6f 6e 63 20 74 6d 70 2d 61 72 65 61 (conc tmp-area
7ec0: 20 22 2f 6d 65 67 61 74 65 73 74 2e 64 62 22 29 "/megatest.db")
7ed0: 29 0a 09 20 28 73 74 61 67 69 6e 67 2d 66 69 6c ).. (staging-fil
7ee0: 65 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 e (conc *toppath
7ef0: 2a 20 22 2f 2e 6d 65 67 61 74 65 73 74 2e 64 62 * "/.megatest.db
7f00: 22 29 29 0a 09 20 28 6d 74 64 62 66 69 6c 65 20 ")).. (mtdbfile
7f10: 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 (conc *toppa
7f20: 74 68 2a 20 22 2f 6d 65 67 61 74 65 73 74 2e 64 th* "/megatest.d
7f30: 62 22 29 29 0a 09 20 28 6c 6f 63 6b 66 69 6c 65 b")).. (lockfile
7f40: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
7f50: 2d 73 79 6e 63 2d 6c 6f 63 6b 2d 66 69 6c 65 70 -sync-lock-filep
7f60: 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 28 ath)). (
7f70: 73 79 6e 63 2d 63 6d 64 2d 63 6f 72 65 20 20 20 sync-cmd-core
7f80: 20 20 28 63 6f 6e 63 20 73 71 6c 69 74 65 2d 65 (conc sqlite-e
7f90: 78 65 22 20 22 20 74 6d 70 2d 64 62 20 22 20 2e xe" " tmp-db " .
7fa0: 64 75 6d 70 20 7c 20 22 73 71 6c 69 74 65 2d 65 dump | "sqlite-e
7fb0: 78 65 22 20 22 20 73 74 61 67 69 6e 67 2d 66 69 xe" " staging-fi
7fc0: 6c 65 20 22 26 3e 22 73 79 6e 63 2d 6c 6f 67 29 le "&>"sync-log)
7fd0: 29 0a 20 20 20 20 20 20 20 20 20 28 73 79 6e 63 ). (sync
7fe0: 2d 63 6d 64 20 20 20 20 20 28 69 66 20 66 6f 72 -cmd (if for
7ff0: 6b 2d 74 6f 2d 62 61 63 6b 67 72 6f 75 6e 64 20 k-to-background
8000: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8010: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
8020: 63 20 22 2f 75 73 72 2f 62 69 6e 2f 65 6e 76 20 c "/usr/bin/env
8030: 4e 42 46 41 4b 45 5f 4c 4f 47 3d 22 2a 74 6f 70 NBFAKE_LOG="*top
8040: 70 61 74 68 2a 22 2f 6c 6f 67 73 2f 6c 61 73 74 path*"/logs/last
8050: 2d 73 65 72 76 65 72 2d 73 79 6e 63 2d 22 28 63 -server-sync-"(c
8060: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
8070: 64 29 22 2e 6c 6f 67 20 6e 62 66 61 6b 65 20 5c d)".log nbfake \
8080: 22 22 73 79 6e 63 2d 63 6d 64 2d 63 6f 72 65 22 ""sync-cmd-core"
8090: 20 26 26 20 2f 62 69 6e 2f 6d 76 20 2d 66 20 22 && /bin/mv -f "
80a0: 20 73 74 61 67 69 6e 67 2d 66 69 6c 65 20 22 20 staging-file "
80b0: 22 20 6d 74 64 62 66 69 6c 65 22 20 5c 22 22 29 " mtdbfile" \"")
80c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
80d0: 20 20 20 20 20 20 20 20 20 20 20 20 73 79 6e 63 sync
80e0: 2d 63 6d 64 2d 63 6f 72 65 29 29 0a 20 20 20 20 -cmd-core)).
80f0: 20 20 20 20 20 28 64 65 66 61 75 6c 74 2d 6d 69 (default-mi
8100: 6e 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 n-intersync-dela
8110: 79 20 32 29 0a 09 20 28 6d 69 6e 2d 69 6e 74 65 y 2).. (min-inte
8120: 72 73 79 6e 63 2d 64 65 6c 61 79 20 28 63 6f 6e rsync-delay (con
8130: 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 figf:lookup-numb
8140: 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 er *configdat* "
8150: 73 65 72 76 65 72 22 20 22 6d 69 6e 69 6d 75 6d server" "minimum
8160: 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 -intersync-delay
8170: 22 20 64 65 66 61 75 6c 74 3a 20 64 65 66 61 75 " default: defau
8180: 6c 74 2d 6d 69 6e 2d 69 6e 74 65 72 73 79 6e 63 lt-min-intersync
8190: 2d 64 65 6c 61 79 29 29 0a 20 20 20 20 20 20 20 -delay)).
81a0: 20 20 28 64 65 66 61 75 6c 74 2d 64 75 74 79 2d (default-duty-
81b0: 63 79 63 6c 65 20 30 2e 31 29 0a 20 20 20 20 20 cycle 0.1).
81c0: 20 20 20 20 28 64 75 74 79 2d 63 79 63 6c 65 20 (duty-cycle
81d0: 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
81e0: 70 2d 6e 75 6d 62 65 72 20 2a 63 6f 6e 66 69 67 p-number *config
81f0: 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 73 dat* "server" "s
8200: 79 6e 63 2d 64 75 74 79 2d 63 79 63 6c 65 22 20 ync-duty-cycle"
8210: 64 65 66 61 75 6c 74 3a 20 64 65 66 61 75 6c 74 default: default
8220: 2d 64 75 74 79 2d 63 79 63 6c 65 29 29 0a 20 20 -duty-cycle)).
8230: 20 20 20 20 20 20 20 28 6c 61 73 74 2d 73 79 6e (last-syn
8240: 63 2d 73 65 63 6f 6e 64 73 20 31 30 29 20 3b 3b c-seconds 10) ;;
8250: 20 77 65 20 77 69 6c 6c 20 61 64 6a 75 73 74 20 we will adjust
8260: 74 68 69 73 20 74 6f 20 61 20 6d 65 61 73 75 72 this to a measur
8270: 65 6d 65 6e 74 20 61 6e 64 20 64 65 6c 61 79 20 ement and delay
8280: 6c 61 73 74 2d 73 79 6e 63 2d 73 65 63 6f 6e 64 last-sync-second
8290: 73 20 2a 20 28 31 20 2d 20 64 75 74 79 2d 63 79 s * (1 - duty-cy
82a0: 63 6c 65 29 0a 20 20 20 20 20 20 20 20 20 28 63 cle). (c
82b0: 61 6c 63 75 6c 61 74 65 2d 6f 66 66 2d 74 69 6d alculate-off-tim
82c0: 65 20 28 6c 61 6d 62 64 61 20 28 77 6f 72 6b 2d e (lambda (work-
82d0: 64 75 72 61 74 69 6f 6e 20 64 75 74 79 2d 63 79 duration duty-cy
82e0: 63 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 cle).
82f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8300: 20 20 20 20 20 20 20 28 2a 20 28 2f 20 28 2d 20 (* (/ (-
8310: 31 20 64 75 74 79 2d 63 79 63 6c 65 29 20 64 75 1 duty-cycle) du
8320: 74 79 2d 63 79 63 6c 65 29 20 6c 61 73 74 2d 73 ty-cycle) last-s
8330: 79 6e 63 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 ync-seconds))).
8340: 20 20 20 20 20 20 20 20 28 6f 66 66 2d 74 69 6d (off-tim
8350: 65 20 6d 69 6e 2d 69 6e 74 65 72 73 79 6e 63 2d e min-intersync-
8360: 64 65 6c 61 79 29 20 3b 3b 20 61 64 6a 75 73 74 delay) ;; adjust
8370: 65 64 20 69 6e 20 63 6c 6f 73 75 72 65 20 62 65 ed in closure be
8380: 6c 6f 77 2e 0a 20 20 20 20 20 20 20 20 20 28 64 low.. (d
8390: 6f 2d 61 2d 73 79 6e 63 0a 20 20 20 20 20 20 20 o-a-sync.
83a0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda ().
83b0: 20 20 20 20 20 20 20 20 20 20 28 42 42 3e 20 22 (BB> "
83c0: 53 74 61 72 74 20 64 6f 2d 61 2d 73 79 6e 63 20 Start do-a-sync
83d0: 77 69 74 68 20 66 6f 72 6b 2d 74 6f 2d 62 61 63 with fork-to-bac
83e0: 6b 67 72 6f 75 6e 64 3d 22 66 6f 72 6b 2d 74 6f kground="fork-to
83f0: 2d 62 61 63 6b 67 72 6f 75 6e 64 22 20 70 65 72 -background" per
8400: 73 69 73 74 2d 75 6e 74 69 6c 2d 73 79 6e 63 3d sist-until-sync=
8410: 22 70 65 72 73 69 73 74 2d 75 6e 74 69 6c 2d 73 "persist-until-s
8420: 79 6e 63 29 0a 20 20 20 20 20 20 20 20 20 20 20 ync).
8430: 20 28 6c 65 74 2a 20 28 28 66 69 6e 61 6c 72 65 (let* ((finalre
8440: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
8450: 20 20 20 20 20 20 28 6c 65 74 20 72 65 74 72 79 (let retry
8460: 2d 6c 6f 6f 70 20 28 28 6e 75 6d 2d 74 72 69 65 -loop ((num-trie
8470: 73 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 s 0)).
8480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8490: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c if (common:simpl
84a0: 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b e-file-lock lock
84b0: 66 69 6c 65 29 0a 09 20 20 20 20 20 20 20 20 20 file)..
84c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
84d0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
84e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84f0: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond.
8500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8510: 20 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 6f ((not (o
8520: 72 20 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 r fork-to-backgr
8530: 6f 75 6e 64 20 70 65 72 73 69 73 74 2d 75 6e 74 ound persist-unt
8540: 69 6c 2d 73 79 6e 63 29 29 0a 20 20 20 20 20 20 il-sync)).
8550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8560: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
8570: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
8580: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
8590: 46 4f 3a 20 73 79 6e 63 65 72 20 74 68 72 65 61 FO: syncer threa
85a0: 64 20 73 6c 65 65 70 69 6e 67 20 66 6f 72 20 6d d sleeping for m
85b0: 61 78 20 6f 66 20 28 73 65 72 76 65 72 2e 6d 69 ax of (server.mi
85c0: 6e 69 6d 75 6d 2d 69 6e 74 65 72 73 79 6e 63 2d nimum-intersync-
85d0: 64 65 6c 61 79 3d 22 6d 69 6e 2d 69 6e 74 65 72 delay="min-inter
85e0: 73 79 6e 63 2d 64 65 6c 61 79 0a 20 20 20 20 20 sync-delay.
85f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8610: 20 20 20 20 20 20 20 20 20 22 20 2c 20 6f 66 66 " , off
8620: 2d 74 69 6d 65 3d 22 6f 66 66 2d 74 69 6d 65 22 -time="off-time"
8630: 20 73 65 63 6f 6e 64 73 20 5d 22 29 0a 20 20 20 seconds ]").
8640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
8660: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 6d 61 hread-sleep! (ma
8670: 78 20 6f 66 66 2d 74 69 6d 65 20 6d 69 6e 2d 69 x off-time min-i
8680: 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 29 29 ntersync-delay))
8690: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
86a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86b0: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 (else.
86c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86d0: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
86e0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
86f0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
8700: 3a 20 73 79 6e 63 65 72 20 74 68 72 65 61 64 20 : syncer thread
8710: 4e 4f 54 20 73 6c 65 65 70 69 6e 67 20 3b 20 6d NOT sleeping ; m
8720: 61 79 62 65 20 74 69 6d 65 2d 74 6f 2d 65 78 69 aybe time-to-exi
8730: 74 2e 2e 2e 22 29 29 29 0a 0a 20 20 20 20 20 20 t...")))..
8740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8750: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
8760: 74 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 t (configf:looku
8770: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
8780: 65 72 76 65 72 22 20 22 64 69 73 61 62 6c 65 2d erver" "disable-
8790: 64 62 2d 73 6e 61 70 73 68 6f 74 22 29 29 0a 20 db-snapshot")).
87a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87c0: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 6e 61 70 73 68 (common:snapsh
87d0: 6f 74 2d 66 69 6c 65 20 6d 74 64 62 66 69 6c 65 ot-file mtdbfile
87e0: 20 73 75 62 64 69 72 3a 20 22 2e 64 62 2d 73 6e subdir: ".db-sn
87f0: 61 70 73 68 6f 74 22 29 29 0a 09 09 20 20 20 20 apshot"))...
8800: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 6c 65 (dele
8810: 74 65 2d 66 69 6c 65 2a 20 73 74 61 67 69 6e 67 te-file* staging
8820: 2d 66 69 6c 65 29 0a 09 09 20 20 20 20 20 20 20 -file)...
8830: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
8840: 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
8850: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
8860: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8880: 20 20 20 20 20 20 20 20 20 28 72 65 73 20 28 73 (res (s
8890: 79 73 74 65 6d 20 73 79 6e 63 2d 63 6d 64 29 29 ystem sync-cmd))
88a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
88b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88c0: 20 20 20 20 20 20 20 28 64 62 62 61 63 6b 75 70 (dbbackup
88d0: 66 69 6c 65 20 28 63 6f 6e 63 20 6d 74 64 62 66 file (conc mtdbf
88e0: 69 6c 65 20 22 2e 62 61 63 6b 75 70 22 29 29 0a ile ".backup")).
88f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8910: 20 20 20 20 20 20 28 72 65 73 32 20 0a 20 20 20 (res2 .
8920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8940: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond.
8950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8970: 20 20 28 28 65 71 3f 20 30 20 72 65 73 20 29 0a ((eq? 0 res ).
8980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89a0: 20 20 20 20 20 20 20 20 20 28 68 61 6e 64 6c 65 (handle
89b0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
89c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89e0: 20 20 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 exn.
89f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a10: 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 #f.
8a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a40: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
8a50: 69 73 74 73 3f 20 64 62 62 61 63 6b 75 70 66 69 ists? dbbackupfi
8a60: 6c 65 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 le)...
8a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a80: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 64 (delete-file* d
8a90: 62 62 61 63 6b 75 70 66 69 6c 65 29 0a 20 20 20 bbackupfile).
8aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ac0: 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 ).
8ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8af0: 20 28 69 66 20 28 65 71 3f 20 30 20 28 66 69 6c (if (eq? 0 (fil
8b00: 65 2d 73 69 7a 65 20 73 79 6e 63 2d 6c 6f 67 29 e-size sync-log)
8b10: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8b40: 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 73 79 6e delete-file* syn
8b50: 63 2d 6c 6f 67 29 29 0a 09 09 20 20 20 20 20 20 c-log))...
8b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b70: 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 (system (conc
8b80: 20 22 2f 62 69 6e 2f 6d 76 20 22 20 73 74 61 67 "/bin/mv " stag
8b90: 69 6e 67 2d 66 69 6c 65 20 22 20 22 20 6d 74 64 ing-file " " mtd
8ba0: 62 66 69 6c 65 29 29 0a 20 20 20 20 20 20 20 20 bfile)).
8bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bd0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bf0: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
8c00: 20 6c 61 73 74 2d 73 79 6e 63 2d 73 65 63 6f 6e last-sync-secon
8c10: 64 73 20 28 2f 20 28 2d 20 28 63 75 72 72 65 6e ds (/ (- (curren
8c20: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 t-milliseconds)
8c30: 73 74 61 72 74 2d 74 69 6d 65 29 20 31 30 30 30 start-time) 1000
8c40: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c60: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
8c70: 21 20 6f 66 66 2d 74 69 6d 65 20 28 63 61 6c 63 ! off-time (calc
8c80: 75 6c 61 74 65 2d 6f 66 66 2d 74 69 6d 65 0a 20 ulate-off-time.
8c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cc0: 20 20 20 20 20 20 20 20 6c 61 73 74 2d 73 79 6e last-syn
8cd0: 63 2d 73 65 63 6f 6e 64 73 0a 20 20 20 20 20 20 c-seconds.
8ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d10: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 (cond.
8d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d50: 20 20 20 28 28 61 6e 64 20 28 6e 75 6d 62 65 72 ((and (number
8d60: 3f 20 64 75 74 79 2d 63 79 63 6c 65 29 20 28 3e ? duty-cycle) (>
8d70: 20 64 75 74 79 2d 63 79 63 6c 65 20 30 29 20 28 duty-cycle 0) (
8d80: 3c 20 64 75 74 79 2d 63 79 63 6c 65 20 31 29 29 < duty-cycle 1))
8d90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8dc0: 20 20 20 20 20 20 20 20 20 20 20 20 64 75 74 79 duty
8dd0: 2d 63 79 63 6c 65 29 0a 20 20 20 20 20 20 20 20 -cycle).
8de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e10: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 (else.
8e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e50: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
8e60: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
8e70: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 5b ort* "WARNING: [
8e80: 22 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 "(common:human-t
8e90: 69 6d 65 29 22 5d 20 73 65 72 76 65 72 2e 73 79 ime)"] server.sy
8ea0: 6e 63 2d 64 75 74 79 2d 63 79 63 6c 65 20 69 73 nc-duty-cycle is
8eb0: 20 69 6e 76 61 6c 69 64 2e 20 20 53 68 6f 75 6c invalid. Shoul
8ec0: 64 20 62 65 20 61 20 6e 75 6d 62 65 72 20 62 65 d be a number be
8ed0: 74 77 65 65 6e 20 30 20 61 6e 64 20 31 2c 20 62 tween 0 and 1, b
8ee0: 75 74 20 22 64 75 74 79 2d 63 79 63 6c 65 22 20 ut "duty-cycle"
8ef0: 77 61 73 20 73 70 65 63 69 66 69 65 64 2e 20 20 was specified.
8f00: 55 73 69 6e 67 20 64 65 66 61 75 6c 74 20 76 61 Using default va
8f10: 6c 75 65 3a 20 22 64 65 66 61 75 6c 74 2d 64 75 lue: "default-du
8f20: 74 79 2d 63 79 63 6c 65 29 0a 20 20 20 20 20 20 ty-cycle).
8f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f60: 20 20 20 20 20 64 65 66 61 75 6c 74 2d 64 75 74 default-dut
8f70: 79 2d 63 79 63 6c 65 29 29 29 29 0a 20 20 20 20 y-cycle)))).
8f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8fa0: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
8fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8fd0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 2a 64 debug:print 1 *d
8fe0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
8ff0: 20 22 49 4e 46 4f 3a 20 5b 22 28 63 6f 6d 6d 6f "INFO: ["(commo
9000: 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 22 5d 20 n:human-time)"]
9010: 70 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 pid="(current-pr
9020: 6f 63 65 73 73 2d 69 64 29 22 20 53 59 4e 43 20 ocess-id)" SYNC
9030: 74 6f 6f 6b 20 22 6c 61 73 74 2d 73 79 6e 63 2d took "last-sync-
9040: 73 65 63 6f 6e 64 73 22 20 73 65 63 22 29 0a 20 seconds" sec").
9050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9070: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
9080: 72 69 6e 74 20 31 20 2a 64 65 66 61 75 6c 74 2d rint 1 *default-
9090: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
90a0: 20 5b 22 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e ["(common:human
90b0: 2d 74 69 6d 65 29 22 5d 20 70 69 64 3d 22 28 63 -time)"] pid="(c
90c0: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
90d0: 64 29 22 20 53 59 4e 43 20 74 6f 6f 6b 20 22 6c d)" SYNC took "l
90e0: 61 73 74 2d 73 79 6e 63 2d 73 65 63 6f 6e 64 73 ast-sync-seconds
90f0: 22 20 73 65 63 20 3b 20 77 69 74 68 20 64 75 74 " sec ; with dut
9100: 79 2d 63 79 63 6c 65 20 6f 66 20 22 64 75 74 79 y-cycle of "duty
9110: 2d 63 79 63 6c 65 22 20 6f 66 66 20 74 69 6d 65 -cycle" off time
9120: 20 69 73 20 6e 6f 77 20 22 6f 66 66 2d 74 69 6d is now "off-tim
9130: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
9140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9150: 20 20 20 20 20 20 20 20 20 20 20 20 27 73 79 6e 'syn
9160: 63 2d 63 6f 6d 70 6c 65 74 65 64 29 29 0a 20 20 c-completed)).
9170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9190: 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 (else.
91a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91c0: 20 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f (system (co
91d0: 6e 63 20 22 2f 62 69 6e 2f 63 70 20 22 73 79 6e nc "/bin/cp "syn
91e0: 63 2d 6c 6f 67 22 20 22 73 79 6e 63 2d 6c 6f 67 c-log" "sync-log
91f0: 22 2e 66 61 69 6c 22 29 29 0a 20 20 20 20 20 20 ".fail")).
9200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9220: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
9230: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
9240: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 5b 22 28 ort* "ERROR: ["(
9250: 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d common:human-tim
9260: 65 29 22 5d 20 53 79 6e 63 20 66 61 69 6c 65 64 e)"] Sync failed
9270: 2e 20 53 65 65 20 6c 6f 67 20 61 74 20 22 73 79 . See log at "sy
9280: 6e 63 2d 6c 6f 67 22 2e 66 61 69 6c 22 29 0a 20 nc-log".fail").
9290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92b0: 20 20 20 20 20 20 20 20 28 69 66 20 28 66 69 6c (if (fil
92c0: 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 e-exists? (conc
92d0: 6d 74 64 62 66 69 6c 65 20 22 2e 62 61 63 6b 75 mtdbfile ".backu
92e0: 70 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 p")).
92f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9310: 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 (system (conc
9320: 22 2f 62 69 6e 2f 63 70 20 22 6d 74 64 62 66 69 "/bin/cp "mtdbfi
9330: 6c 65 20 22 2e 62 61 63 6b 75 70 20 22 20 6d 74 le ".backup " mt
9340: 64 62 66 69 6c 65 29 29 29 0a 20 20 20 20 20 20 dbfile))).
9350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9370: 20 20 20 23 66 29 29 29 29 0a 20 20 20 20 20 20 #f)))).
9380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9390: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d (comm
93a0: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 on:simple-file-r
93b0: 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b elease-lock lock
93c0: 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 file).
93d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93e0: 20 20 20 20 20 20 20 28 42 42 3e 20 22 72 65 6c (BB> "rel
93f0: 65 61 73 65 64 20 6c 6f 63 6b 66 69 6c 65 3a 20 eased lockfile:
9400: 22 20 6c 6f 63 6b 66 69 6c 65 29 0a 20 20 20 20 " lockfile).
9410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9420: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 68 (wh
9430: 65 6e 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d en (common:file-
9440: 65 78 69 73 74 73 3f 20 6c 6f 63 6b 66 69 6c 65 exists? lockfile
9450: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9470: 20 20 20 20 20 28 42 42 3e 20 22 44 49 44 20 4e (BB> "DID N
9480: 4f 54 20 41 43 54 55 41 4c 4c 59 20 52 45 4c 45 OT ACTUALLY RELE
9490: 41 53 45 20 4c 4f 43 4b 46 49 4c 45 22 29 29 0a ASE LOCKFILE")).
94a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
94b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
94c0: 20 72 65 73 32 29 20 3b 3b 20 65 6e 64 20 6c 65 res2) ;; end le
94d0: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
94e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
94f0: 20 29 3b 3b 20 65 6e 64 20 62 65 67 69 6e 0a 20 );; end begin.
9500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9510: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 65 ;; e
9520: 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 lse.
9530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9540: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
9550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9560: 20 20 20 20 20 28 70 65 72 73 69 73 74 2d 75 6e (persist-un
9570: 74 69 6c 2d 73 79 6e 63 0a 20 20 20 20 20 20 20 til-sync.
9580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9590: 20 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d (thread-
95a0: 73 6c 65 65 70 21 20 31 29 0a 20 20 20 20 20 20 sleep! 1).
95b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
95c0: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
95d0: 70 72 69 6e 74 20 31 20 2a 64 65 66 61 75 6c 74 print 1 *default
95e0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
95f0: 3a 20 5b 22 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 : ["(common:huma
9600: 6e 2d 74 69 6d 65 29 22 5d 20 70 69 64 3d 22 28 n-time)"] pid="(
9610: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
9620: 69 64 29 22 20 6f 74 68 65 72 20 53 59 4e 43 20 id)" other SYNC
9630: 69 6e 20 70 72 6f 67 72 65 73 73 3b 20 77 65 27 in progress; we'
9640: 72 65 20 69 6e 20 61 20 66 6f 72 6b 2d 74 6f 2d re in a fork-to-
9650: 62 61 63 6b 67 72 6f 75 6e 64 20 73 6f 20 77 65 background so we
9660: 20 6e 65 65 64 20 74 6f 20 73 75 63 63 65 65 64 need to succeed
9670: 2e 20 20 4c 65 74 27 73 20 77 61 69 74 20 61 20 . Let's wait a
9680: 6a 69 66 66 79 20 61 6e 64 20 61 6e 64 20 74 72 jiffy and and tr
9690: 79 20 61 67 61 69 6e 2e 20 6e 75 6d 2d 74 72 69 y again. num-tri
96a0: 65 73 3d 22 6e 75 6d 2d 74 72 69 65 73 22 20 28 es="num-tries" (
96b0: 77 61 69 74 69 6e 67 20 66 6f 72 20 6c 6f 63 6b waiting for lock
96c0: 66 69 6c 65 3d 22 6c 6f 63 6b 66 69 6c 65 22 20 file="lockfile"
96d0: 74 6f 20 64 69 73 61 70 70 65 61 72 29 22 29 0a to disappear)").
96e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9700: 72 65 74 72 79 2d 6c 6f 6f 70 20 28 61 64 64 31 retry-loop (add1
9710: 20 6e 75 6d 2d 74 72 69 65 73 29 29 29 0a 20 20 num-tries))).
9720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9730: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
9740: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
9750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9760: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
9770: 28 6d 61 78 20 6f 66 66 2d 74 69 6d 65 20 28 2b (max off-time (+
9780: 20 6c 61 73 74 2d 73 79 6e 63 2d 73 65 63 6f 6e last-sync-secon
9790: 64 73 20 6d 69 6e 2d 69 6e 74 65 72 73 79 6e 63 ds min-intersync
97a0: 2d 64 65 6c 61 79 29 29 29 0a 20 20 20 20 20 20 -delay))).
97b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97c0: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
97d0: 70 72 69 6e 74 20 31 20 2a 64 65 66 61 75 6c 74 print 1 *default
97e0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
97f0: 3a 20 5b 22 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 : ["(common:huma
9800: 6e 2d 74 69 6d 65 29 22 5d 20 70 69 64 3d 22 28 n-time)"] pid="(
9810: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
9820: 69 64 29 22 20 6f 74 68 65 72 20 53 59 4e 43 20 id)" other SYNC
9830: 69 6e 20 70 72 6f 67 72 65 73 73 3b 20 6e 6f 74 in progress; not
9840: 20 73 79 6e 63 69 6e 67 2e 22 29 0a 20 20 20 20 syncing.").
9850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9860: 20 20 20 20 20 20 20 20 20 20 20 27 70 61 72 61 'para
9870: 6c 6c 65 6c 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f llel-sync-in-pro
9880: 67 72 65 73 73 29 29 0a 20 20 20 20 20 20 20 20 gress)).
9890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98a0: 20 20 20 20 20 29 20 3b 3b 20 65 6e 64 20 69 66 ) ;; end if
98b0: 20 67 6f 74 20 6c 6f 63 6b 66 69 6c 65 0a 20 20 got lockfile.
98c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98d0: 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 ).
98e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 0a )).
98f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 42 (B
9900: 42 3e 20 22 45 6e 64 20 64 6f 2d 61 2d 73 79 6e B> "End do-a-syn
9910: 63 20 77 69 74 68 20 66 6f 72 6b 2d 74 6f 2d 62 c with fork-to-b
9920: 61 63 6b 67 72 6f 75 6e 64 3d 22 66 6f 72 6b 2d ackground="fork-
9930: 74 6f 2d 62 61 63 6b 67 72 6f 75 6e 64 22 20 70 to-background" p
9940: 65 72 73 69 73 74 2d 75 6e 74 69 6c 2d 73 79 6e ersist-until-syn
9950: 63 3d 22 70 65 72 73 69 73 74 2d 75 6e 74 69 6c c="persist-until
9960: 2d 73 79 6e 63 22 20 61 6e 64 20 72 65 73 75 6c -sync" and resul
9970: 74 3d 22 66 69 6e 61 6c 72 65 73 29 0a 20 20 20 t="finalres).
9980: 20 20 20 20 20 20 20 20 20 20 20 66 69 6e 61 6c final
9990: 72 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 res).
99a0: 20 29 20 3b 3b 20 65 6e 64 20 6c 61 6d 62 64 61 ) ;; end lambda
99b0: 0a 20 20 20 20 20 20 20 20 20 20 29 29 0a 20 20 . )).
99c0: 20 20 64 6f 2d 61 2d 73 79 6e 63 29 29 0a 0a do-a-sync))..