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 73 65 72 76 65 72 files. (server
4e30: 3a 63 6c 65 61 6e 2d 75 70 2d 6f 6c 64 20 61 72 :clean-up-old ar
4e40: 65 61 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 eapath). (let*
4e50: 28 28 73 69 6e 63 65 2d 6c 61 73 74 20 28 2d 20 ((since-last (-
4e60: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
4e70: 29 20 73 65 72 76 65 72 2d 6c 61 73 74 2d 73 74 ) server-last-st
4e80: 61 72 74 29 29 0a 20 20 20 20 20 20 20 20 28 73 art)). (s
4e90: 65 72 76 65 72 2d 73 74 61 72 74 2d 64 65 6c 61 erver-start-dela
4ea0: 79 20 31 30 29 29 20 20 20 20 20 0a 20 20 20 20 y 10)) .
4eb0: 28 69 66 20 28 20 3c 20 28 2d 20 28 63 75 72 72 (if ( < (- (curr
4ec0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 65 72 ent-seconds) ser
4ed0: 76 65 72 2d 6c 61 73 74 2d 73 74 61 72 74 29 20 ver-last-start)
4ee0: 31 30 20 29 0a 20 20 20 20 20 20 28 62 65 67 69 10 ). (begi
4ef0: 6e 0a 20 20 20 20 20 20 20 20 28 64 65 62 75 67 n. (debug
4f00: 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c :print 2 *defaul
4f10: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 72 t-log-port* "ser
4f20: 76 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 76 65 ver:choose-serve
4f30: 72 3a 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 r: seconds since
4f40: 20 6c 61 73 74 20 73 65 72 76 65 72 20 73 74 61 last server sta
4f50: 72 74 3a 20 22 20 28 2d 20 28 63 75 72 72 65 6e rt: " (- (curren
4f60: 74 2d 73 65 63 6f 6e 64 73 29 20 73 65 72 76 65 t-seconds) serve
4f70: 72 2d 6c 61 73 74 2d 73 74 61 72 74 29 29 0a 20 r-last-start)).
4f80: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
4f90: 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c int 2 *default-l
4fa0: 6f 67 2d 70 6f 72 74 2a 20 22 73 65 72 76 65 72 og-port* "server
4fb0: 3a 63 68 6f 6f 73 65 2d 73 65 72 76 65 72 3a 20 :choose-server:
4fc0: 6c 61 73 74 20 73 65 72 76 65 72 20 73 74 61 72 last server star
4fd0: 74 20 6c 65 73 73 20 74 68 61 6e 20 22 20 73 65 t less than " se
4fe0: 72 76 65 72 2d 73 74 61 72 74 2d 64 65 6c 61 79 rver-start-delay
4ff0: 20 22 20 73 65 63 6f 6e 64 73 20 61 67 6f 2e 20 " seconds ago.
5000: 53 6c 65 65 70 69 6e 67 20 22 20 73 65 72 76 65 Sleeping " serve
5010: 72 2d 73 74 61 72 74 2d 64 65 6c 61 79 20 22 20 r-start-delay "
5020: 73 65 63 6f 6e 64 73 22 29 0a 20 20 20 20 20 20 seconds").
5030: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
5040: 20 73 65 72 76 65 72 2d 73 74 61 72 74 2d 64 65 server-start-de
5050: 6c 61 79 29 0a 20 20 20 20 20 20 29 0a 20 20 20 lay). ).
5060: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5070: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
5080: 6f 72 74 2a 20 22 73 65 72 76 65 72 3a 63 68 6f ort* "server:cho
5090: 6f 73 65 2d 73 65 72 76 65 72 3a 20 73 65 63 6f ose-server: seco
50a0: 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 74 20 73 nds since last s
50b0: 65 72 76 65 72 20 73 74 61 72 74 3a 20 22 20 28 erver start: " (
50c0: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
50d0: 64 73 29 20 73 65 72 76 65 72 2d 6c 61 73 74 2d ds) server-last-
50e0: 73 74 61 72 74 29 29 0a 20 20 20 20 29 0a 20 20 start)). ).
50f0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 ). (let* ((serv
5100: 65 72 73 64 61 74 20 20 28 73 65 72 76 65 72 3a ersdat (server:
5110: 67 65 74 2d 73 65 72 76 65 72 73 2d 69 6e 66 6f get-servers-info
5120: 20 61 72 65 61 70 61 74 68 29 29 0a 09 20 28 73 areapath)).. (s
5130: 65 72 76 6b 65 79 73 20 20 20 20 28 68 61 73 68 ervkeys (hash
5140: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 65 72 76 -table-keys serv
5150: 65 72 73 64 61 74 29 29 0a 09 20 28 62 79 2d 74 ersdat)).. (by-t
5160: 69 6d 65 2d 61 73 63 20 28 69 66 20 28 6e 6f 74 ime-asc (if (not
5170: 20 28 6e 75 6c 6c 3f 20 73 65 72 76 6b 65 79 73 (null? servkeys
5180: 29 29 20 3b 3b 20 4e 4f 54 45 3a 20 4f 6c 64 65 )) ;; NOTE: Olde
5190: 73 74 20 69 73 20 6c 61 73 74 0a 09 09 09 20 20 st is last....
51a0: 28 73 6f 72 74 20 73 65 72 76 6b 65 79 73 20 3b (sort servkeys ;
51b0: 3b 20 6c 69 73 74 20 6f 66 20 22 68 6f 73 74 3a ; list of "host:
51c0: 70 6f 72 74 22 0a 09 09 09 09 28 6c 61 6d 62 64 port".....(lambd
51d0: 61 20 28 61 20 62 29 0a 09 09 09 09 20 20 28 3e a (a b)..... (>
51e0: 3d 20 28 6c 69 73 74 2d 72 65 66 20 28 68 61 73 = (list-ref (has
51f0: 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 65 72 76 h-table-ref serv
5200: 65 72 73 64 61 74 20 61 29 20 32 29 0a 09 09 09 ersdat a) 2)....
5210: 09 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 . (list-ref
5220: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5230: 20 73 65 72 76 65 72 73 64 61 74 20 62 29 20 32 serversdat b) 2
5240: 29 29 29 29 0a 09 09 09 20 20 27 28 29 29 29 29 )))).... '())))
5250: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
5260: 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 2 *default-log
5270: 2d 70 6f 72 74 2a 20 22 73 65 72 76 65 72 3a 63 -port* "server:c
5280: 68 6f 6f 73 65 2d 73 65 72 76 65 72 3a 20 73 65 hoose-server: se
5290: 72 76 65 72 73 64 61 74 3a 20 22 20 73 65 72 76 rversdat: " serv
52a0: 65 72 73 64 61 74 29 0a 20 20 20 20 28 64 65 62 ersdat). (deb
52b0: 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 ug:print 2 *defa
52c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 ult-log-port* "s
52d0: 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 erver:choose-ser
52e0: 76 65 72 3a 20 73 65 72 76 6b 65 79 73 3a 20 22 ver: servkeys: "
52f0: 20 73 65 72 76 6b 65 79 73 29 0a 20 20 20 20 28 servkeys). (
5300: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 if (not (null? b
5310: 79 2d 74 69 6d 65 2d 61 73 63 29 29 0a 09 28 6c y-time-asc))..(l
5320: 65 74 2a 20 28 28 6f 6c 64 65 73 74 20 20 20 20 et* ((oldest
5330: 20 28 6c 61 73 74 20 62 79 2d 74 69 6d 65 2d 61 (last by-time-a
5340: 73 63 29 29 0a 09 20 20 20 20 20 20 20 28 6f 6c sc)).. (ol
5350: 64 65 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 dest-dat (hash-t
5360: 61 62 6c 65 2d 72 65 66 20 73 65 72 76 65 72 73 able-ref servers
5370: 64 61 74 20 6f 6c 64 65 73 74 29 29 0a 09 20 20 dat oldest))..
5380: 20 20 20 20 20 28 68 6f 73 74 20 20 20 20 20 20 (host
5390: 20 28 6c 69 73 74 2d 72 65 66 20 6f 6c 64 65 73 (list-ref oldes
53a0: 74 2d 64 61 74 20 30 29 29 0a 09 20 20 20 20 20 t-dat 0))..
53b0: 20 20 28 61 6c 6c 2d 76 61 6c 69 64 20 20 28 66 (all-valid (f
53c0: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
53d0: 29 0a 09 09 09 09 20 20 20 20 20 28 65 71 75 61 )..... (equa
53e0: 6c 3f 20 68 6f 73 74 20 28 6c 69 73 74 2d 72 65 l? host (list-re
53f0: 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 f (hash-table-re
5400: 66 20 73 65 72 76 65 72 73 64 61 74 20 78 29 20 f serversdat x)
5410: 30 29 29 29 0a 09 09 09 09 20 20 20 62 79 2d 74 0)))..... by-t
5420: 69 6d 65 2d 61 73 63 29 29 0a 09 20 20 20 20 20 ime-asc))..
5430: 20 20 28 62 65 73 74 2d 74 65 6e 20 20 28 6c 61 (best-ten (la
5440: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 mbda ()....
5450: 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 61 (if (> (length a
5460: 6c 6c 2d 76 61 6c 69 64 29 20 31 31 29 0a 09 09 ll-valid) 11)...
5470: 09 09 20 28 74 61 6b 65 20 28 64 72 6f 70 2d 72 .. (take (drop-r
5480: 69 67 68 74 20 61 6c 6c 2d 76 61 6c 69 64 20 31 ight all-valid 1
5490: 29 20 31 30 29 20 3b 3b 20 72 65 6d 6f 76 65 20 ) 10) ;; remove
54a0: 74 68 65 20 6f 6c 64 65 73 74 20 66 72 6f 6d 20 the oldest from
54b0: 63 6f 6e 73 69 64 65 72 61 74 69 6f 6e 20 73 6f consideration so
54c0: 20 69 74 20 63 61 6e 20 61 67 65 20 6f 75 74 0a it can age out.
54d0: 09 09 09 09 20 28 69 66 20 28 3e 20 28 6c 65 6e .... (if (> (len
54e0: 67 74 68 20 61 6c 6c 2d 76 61 6c 69 64 29 20 38 gth all-valid) 8
54f0: 29 0a 09 09 09 09 20 20 20 20 20 28 64 72 6f 70 )..... (drop
5500: 2d 72 69 67 68 74 20 61 6c 6c 2d 76 61 6c 69 64 -right all-valid
5510: 20 31 29 0a 09 09 09 09 20 20 20 20 20 61 6c 6c 1)..... all
5520: 2d 76 61 6c 69 64 29 29 29 29 0a 09 20 20 20 20 -valid))))..
5530: 20 20 20 28 6e 61 6d 65 73 2d 3e 64 61 74 73 20 (names->dats
5540: 28 6c 61 6d 62 64 61 20 28 6e 61 6d 65 73 29 0a (lambda (names).
5550: 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c ... (map (l
5560: 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 20 20 ambda (x).....
5570: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
5580: 65 66 20 73 65 72 76 65 72 73 64 61 74 20 78 29 ef serversdat x)
5590: 29 0a 09 09 09 09 20 20 20 6e 61 6d 65 73 29 29 )..... names))
55a0: 29 0a 09 20 20 20 20 20 20 20 28 61 6d 2d 68 6f ).. (am-ho
55b0: 6d 65 3f 20 20 20 20 28 6c 61 6d 62 64 61 20 28 me? (lambda (
55c0: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 2a ).... (let*
55d0: 20 28 28 63 75 72 72 68 6f 73 74 20 28 67 65 74 ((currhost (get
55e0: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 09 09 -host-name))....
55f0: 09 20 20 20 20 20 28 62 65 73 74 61 64 72 73 20 . (bestadrs
5600: 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 (server:get-best
5610: 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 63 -guess-address c
5620: 75 72 72 68 6f 73 74 29 29 29 0a 09 09 09 09 28 urrhost))).....(
5630: 6f 72 20 28 65 71 75 61 6c 3f 20 68 6f 73 74 20 or (equal? host
5640: 63 75 72 72 68 6f 73 74 29 0a 09 09 09 09 20 20 currhost).....
5650: 20 20 28 65 71 75 61 6c 3f 20 68 6f 73 74 20 62 (equal? host b
5660: 65 73 74 61 64 72 73 29 29 29 29 29 29 0a 09 20 estadrs))))))..
5670: 20 28 63 61 73 65 20 6d 6f 64 65 0a 09 20 20 20 (case mode..
5680: 20 28 28 69 6e 66 6f 29 0a 09 20 20 20 20 20 28 ((info).. (
5690: 70 72 69 6e 74 20 22 6f 6c 64 65 73 74 3a 20 22 print "oldest: "
56a0: 6f 6c 64 65 73 74 2d 64 61 74 22 2c 20 73 65 6c oldest-dat", sel
56b0: 65 63 74 65 64 20 68 6f 73 74 3a 20 22 68 6f 73 ected host: "hos
56c0: 74 22 2c 20 61 6c 6c 2d 76 61 6c 69 64 3a 20 22 t", all-valid: "
56d0: 61 6c 6c 2d 76 61 6c 69 64 29 0a 09 20 20 20 20 all-valid)..
56e0: 20 28 70 72 69 6e 74 20 22 79 6f 75 6e 67 65 73 (print "younges
56f0: 74 3a 20 22 28 68 61 73 68 2d 74 61 62 6c 65 2d t: "(hash-table-
5700: 72 65 66 20 73 65 72 76 65 72 73 64 61 74 20 28 ref serversdat (
5710: 63 61 72 20 61 6c 6c 2d 76 61 6c 69 64 29 29 29 car all-valid)))
5720: 29 0a 09 20 20 20 20 28 28 68 6f 6d 65 29 20 20 ).. ((home)
5730: 20 20 20 68 6f 73 74 29 0a 09 20 20 20 20 28 28 host).. ((
5740: 68 6f 6d 65 68 6f 73 74 29 20 28 63 6f 6e 73 20 homehost) (cons
5750: 68 6f 73 74 20 28 61 6d 2d 68 6f 6d 65 3f 29 29 host (am-home?))
5760: 29 20 3b 3b 20 73 68 75 74 20 75 70 20 6f 6c 64 ) ;; shut up old
5770: 20 63 6f 64 65 0a 09 20 20 20 20 28 28 68 6f 6d code.. ((hom
5780: 65 3f 29 20 20 20 20 28 61 6d 2d 68 6f 6d 65 3f e?) (am-home?
5790: 29 29 0a 09 20 20 20 20 28 28 62 65 73 74 2d 74 )).. ((best-t
57a0: 65 6e 29 28 6e 61 6d 65 73 2d 3e 64 61 74 73 20 en)(names->dats
57b0: 28 62 65 73 74 2d 74 65 6e 29 29 29 0a 09 20 20 (best-ten)))..
57c0: 20 20 28 28 61 6c 6c 2d 76 61 6c 69 64 29 28 6e ((all-valid)(n
57d0: 61 6d 65 73 2d 3e 64 61 74 73 20 61 6c 6c 2d 76 ames->dats all-v
57e0: 61 6c 69 64 29 29 0a 09 20 20 20 20 28 28 62 65 alid)).. ((be
57f0: 73 74 29 20 20 20 20 20 28 6c 65 74 2a 20 28 28 st) (let* ((
5800: 62 65 73 74 2d 74 65 6e 20 28 62 65 73 74 2d 74 best-ten (best-t
5810: 65 6e 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 en)).... (
5820: 6c 65 6e 20 20 20 20 20 20 20 28 6c 65 6e 67 74 len (lengt
5830: 68 20 62 65 73 74 2d 74 65 6e 29 29 29 0a 09 09 h best-ten)))...
5840: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 . (hash-table-r
5850: 65 66 20 73 65 72 76 65 72 73 64 61 74 20 28 6c ef serversdat (l
5860: 69 73 74 2d 72 65 66 20 62 65 73 74 2d 74 65 6e ist-ref best-ten
5870: 20 28 72 61 6e 64 6f 6d 20 6c 65 6e 29 29 29 29 (random len))))
5880: 29 0a 09 20 20 20 20 28 28 63 6f 75 6e 74 29 28 ).. ((count)(
5890: 6c 65 6e 67 74 68 20 61 6c 6c 2d 76 61 6c 69 64 length all-valid
58a0: 29 29 0a 09 20 20 20 20 28 65 6c 73 65 0a 09 20 )).. (else..
58b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
58c0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
58d0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 69 6e port* "ERROR: in
58e0: 76 61 6c 69 64 20 63 6f 6d 6d 61 6e 64 20 22 6d valid command "m
58f0: 6f 64 65 29 0a 09 20 20 20 20 20 23 66 29 29 29 ode).. #f)))
5900: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 72 ..(begin.. (ser
5910: 76 65 72 3a 72 75 6e 20 61 72 65 61 70 61 74 68 ver:run areapath
5920: 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 65 74 ). (set
5930: 21 20 73 65 72 76 65 72 2d 6c 61 73 74 2d 73 74 ! server-last-st
5940: 61 72 74 20 28 63 75 72 72 65 6e 74 2d 73 65 63 art (current-sec
5950: 6f 6e 64 73 29 29 0a 09 20 20 3b 3b 20 28 74 68 onds)).. ;; (th
5960: 72 65 61 64 2d 73 6c 65 65 70 21 20 33 29 0a 09 read-sleep! 3)..
5970: 20 20 28 63 61 73 65 20 6d 6f 64 65 0a 09 20 20 (case mode..
5980: 20 20 28 28 68 6f 6d 65 68 6f 73 74 29 20 28 63 ((homehost) (c
5990: 6f 6e 73 20 23 66 20 23 66 29 29 0a 09 20 20 20 ons #f #f))..
59a0: 20 28 65 6c 73 65 09 23 66 29 29 29 29 29 29 0a (else.#f)))))).
59b0: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
59c0: 3a 67 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 :get-servinfo-di
59d0: 72 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 6c r areapath). (l
59e0: 65 74 2a 20 28 28 73 70 61 74 68 20 28 63 6f 6e et* ((spath (con
59f0: 63 20 61 72 65 61 70 61 74 68 22 2f 2e 73 65 72 c areapath"/.ser
5a00: 76 69 6e 66 6f 22 29 29 29 0a 20 20 20 20 28 69 vinfo"))). (i
5a10: 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 f (not (file-exi
5a20: 73 74 73 3f 20 73 70 61 74 68 29 29 0a 09 28 63 sts? spath))..(c
5a30: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
5a40: 73 70 61 74 68 20 23 74 29 29 0a 20 20 20 20 73 spath #t)). s
5a50: 70 61 74 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 path))..(define
5a60: 28 73 65 72 76 65 72 3a 63 6c 65 61 6e 2d 75 70 (server:clean-up
5a70: 2d 6f 6c 64 20 61 72 65 61 70 61 74 68 29 0a 20 -old areapath).
5a80: 20 3b 3b 20 61 6e 79 20 73 65 72 76 65 72 20 66 ;; any server f
5a90: 69 6c 65 20 74 68 61 74 20 68 61 73 20 6e 6f 74 ile that has not
5aa0: 20 62 65 65 6e 20 74 6f 75 63 68 65 64 20 69 6e been touched in
5ab0: 20 74 65 6e 20 6d 69 6e 75 74 65 73 20 69 73 20 ten minutes is
5ac0: 65 66 66 65 63 74 69 76 65 6c 79 20 64 65 61 64 effectively dead
5ad0: 0a 20 20 28 6c 65 74 2a 20 28 28 73 66 69 6c 65 . (let* ((sfile
5ae0: 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 28 73 s (glob (conc (s
5af0: 65 72 76 65 72 3a 67 65 74 2d 73 65 72 76 69 6e erver:get-servin
5b00: 66 6f 2d 64 69 72 20 61 72 65 61 70 61 74 68 29 fo-dir areapath)
5b10: 22 2f 2a 22 29 29 29 29 0a 20 20 20 20 28 66 6f "/*")))). (fo
5b20: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
5b30: 62 64 61 20 28 73 66 69 6c 65 29 0a 20 20 20 20 bda (sfile).
5b40: 20 20 20 28 6c 65 74 2a 20 28 28 6d 6f 64 74 69 (let* ((modti
5b50: 6d 65 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 me (handle-excep
5b60: 74 69 6f 6e 73 0a 09 09 09 20 20 20 65 78 6e 0a tions.... exn.
5b70: 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 20 ... (begin....
5b80: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
5b90: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5ba0: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 t* "WARNING: fai
5bb0: 6c 65 64 20 74 6f 20 67 65 74 20 6d 6f 64 69 66 led to get modif
5bc0: 69 63 61 74 69 6f 6e 20 66 69 6c 65 20 66 6f 72 ication file for
5bd0: 20 22 73 66 69 6c 65 29 0a 09 09 09 20 20 20 28 "sfile).... (
5be0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
5bf0: 29 0a 09 09 09 20 28 66 69 6c 65 2d 6d 6f 64 69 ).... (file-modi
5c00: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 66 fication-time sf
5c10: 69 6c 65 29 29 29 29 0a 09 20 28 69 66 20 28 61 ile)))).. (if (a
5c20: 6e 64 20 28 6e 75 6d 62 65 72 3f 20 6d 6f 64 74 nd (number? modt
5c30: 69 6d 65 29 0a 09 09 20 20 28 3e 20 28 2d 20 28 ime)... (> (- (
5c40: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
5c50: 20 6d 6f 64 74 69 6d 65 29 0a 09 09 20 20 20 20 modtime)...
5c60: 20 36 30 30 29 29 0a 09 20 20 20 20 20 28 62 65 600)).. (be
5c70: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 64 65 62 gin.. (deb
5c80: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
5c90: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
5ca0: 41 52 4e 49 4e 47 3a 20 66 6f 75 6e 64 20 6f 6c ARNING: found ol
5cb0: 64 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 69 d server info fi
5cc0: 6c 65 20 22 73 66 69 6c 65 22 2c 20 72 65 6d 6f le "sfile", remo
5cd0: 76 69 6e 67 20 69 74 2e 22 29 0a 09 20 20 20 20 ving it.")..
5ce0: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
5cf0: 74 69 6f 6e 73 0a 09 09 20 20 20 65 78 6e 0a 09 tions... exn..
5d00: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 . (debug:print 0
5d10: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5d20: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 rt* "WARNING: fa
5d30: 69 6c 65 64 20 74 6f 20 64 65 6c 65 74 65 20 6f iled to delete o
5d40: 6c 64 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 ld server info f
5d50: 69 6c 65 20 22 73 66 69 6c 65 29 0a 09 09 20 28 ile "sfile)... (
5d60: 64 65 6c 65 74 65 2d 66 69 6c 65 20 73 66 69 6c delete-file sfil
5d70: 65 29 29 29 29 29 29 0a 20 20 20 20 20 73 66 69 e)))))). sfi
5d80: 6c 65 73 29 29 29 0a 0a 3b 3b 20 77 6f 75 6c 64 les)))..;; would
5d90: 20 6c 69 6b 65 20 74 6f 20 65 76 65 6e 74 75 61 like to eventua
5da0: 6c 6c 79 20 67 65 74 20 72 69 64 20 6f 66 20 74 lly get rid of t
5db0: 68 69 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 his.;;.(define (
5dc0: 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f common:on-homeho
5dd0: 73 74 3f 29 0a 20 20 28 73 65 72 76 65 72 3a 63 st?). (server:c
5de0: 68 6f 6f 73 65 2d 73 65 72 76 65 72 20 2a 74 6f hoose-server *to
5df0: 70 70 61 74 68 2a 20 27 68 6f 6d 65 3f 29 29 0a ppath* 'home?)).
5e00: 0a 3b 3b 20 6b 69 6e 64 20 73 74 61 72 74 20 75 .;; kind start u
5e10: 70 20 6f 66 20 73 65 72 76 65 72 2c 20 77 61 69 p of server, wai
5e20: 74 20 62 65 66 6f 72 65 20 61 6c 6c 6f 77 69 6e t before allowin
5e30: 67 20 61 6e 6f 74 68 65 72 20 73 65 72 76 65 72 g another server
5e40: 20 66 6f 72 20 61 20 67 69 76 65 6e 0a 3b 3b 20 for a given.;;
5e50: 61 72 65 61 20 74 6f 20 62 65 20 6c 61 75 6e 63 area to be launc
5e60: 68 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 hed.;;.(define (
5e70: 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 server:kind-run
5e80: 61 72 65 61 70 61 74 68 29 0a 20 20 3b 3b 20 6c areapath). ;; l
5e90: 6f 6f 6b 20 66 6f 72 20 24 4d 54 5f 52 55 4e 5f ook for $MT_RUN_
5ea0: 41 52 45 41 5f 48 4f 4d 45 2f 6c 6f 67 73 2f 73 AREA_HOME/logs/s
5eb0: 65 72 76 65 72 2d 73 74 61 72 74 2d 6c 61 73 74 erver-start-last
5ec0: 0a 20 20 3b 3b 20 61 6e 64 20 77 61 69 74 20 66 . ;; and wait f
5ed0: 6f 72 20 69 74 20 74 6f 20 62 65 20 61 74 20 6c or it to be at l
5ee0: 65 61 73 74 20 3c 73 65 72 76 65 72 20 69 64 6c east <server idl
5ef0: 65 74 69 6d 65 3e 20 73 65 63 6f 6e 64 73 20 6f etime> seconds o
5f00: 6c 64 0a 20 20 3b 3b 20 28 73 65 72 76 65 72 3a ld. ;; (server:
5f10: 77 61 69 74 2d 66 6f 72 2d 73 65 72 76 65 72 2d wait-for-server-
5f20: 73 74 61 72 74 2d 6c 61 73 74 2d 66 6c 61 67 20 start-last-flag
5f30: 61 72 65 61 70 61 74 68 29 0a 20 20 28 6c 65 74 areapath). (let
5f40: 20 6c 6f 6f 70 20 28 29 0a 20 20 20 20 28 69 66 loop (). (if
5f50: 20 28 3e 20 28 61 6c 69 73 74 2d 72 65 66 20 27 (> (alist-ref '
5f60: 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 28 63 adj-proc-load (c
5f70: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d 61 6c ommon:get-normal
5f80: 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 20 23 66 ized-cpu-load #f
5f90: 29 29 20 32 29 0a 09 28 62 65 67 69 6e 0a 09 20 )) 2)..(begin..
5fa0: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (if (common:low
5fb0: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 20 -noise-print 30
5fc0: 22 6f 75 72 2d 68 6f 73 74 2d 6c 6f 61 64 22 29 "our-host-load")
5fd0: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
5fe0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
5ff0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
6000: 4e 47 3a 20 73 79 73 74 65 6d 20 6c 6f 61 64 20 NG: system load
6010: 69 73 20 68 69 67 68 2c 20 77 61 69 74 69 6e 67 is high, waiting
6020: 20 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 to start server
6030: 2e 22 29 29 0a 09 20 20 28 6c 6f 6f 70 29 29 29 .")).. (loop)))
6040: 29 0a 20 20 28 69 66 20 28 3c 20 28 73 65 72 76 ). (if (< (serv
6050: 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 76 65 72 er:choose-server
6060: 20 61 72 65 61 70 61 74 68 20 27 63 6f 75 6e 74 areapath 'count
6070: 29 20 32 30 29 0a 20 20 20 20 20 20 28 73 65 72 ) 20). (ser
6080: 76 65 72 3a 72 75 6e 20 61 72 65 61 70 61 74 68 ver:run areapath
6090: 29 29 0a 20 20 23 3b 28 69 66 20 28 6e 6f 74 20 )). #;(if (not
60a0: 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 (server:check-if
60b0: 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 61 74 -running areapat
60c0: 68 29 29 20 3b 3b 20 77 68 79 20 74 72 79 20 69 h)) ;; why try i
60d0: 66 20 74 68 65 72 65 20 69 73 20 61 6c 72 65 61 f there is alrea
60e0: 64 79 20 61 20 73 65 72 76 65 72 20 72 75 6e 6e dy a server runn
60f0: 69 6e 67 3f 0a 20 20 20 20 20 20 28 6c 65 74 2a ing?. (let*
6100: 20 28 28 6c 6f 63 6b 2d 66 69 6c 65 20 20 20 20 ((lock-file
6110: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 (conc areapath "
6120: 2f 6c 6f 67 73 2f 73 65 72 76 65 72 2d 73 74 61 /logs/server-sta
6130: 72 74 2e 6c 6f 63 6b 22 29 29 29 0a 09 28 6c 65 rt.lock")))..(le
6140: 74 2a 20 28 28 73 74 61 72 74 2d 66 6c 61 67 20 t* ((start-flag
6150: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 (conc areapath "
6160: 2f 6c 6f 67 73 2f 73 65 72 76 65 72 2d 73 74 61 /logs/server-sta
6170: 72 74 2d 6c 61 73 74 22 29 29 29 0a 09 20 20 28 rt-last"))).. (
6180: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
6190: 6c 65 2d 6c 6f 63 6b 2d 61 6e 64 2d 77 61 69 74 le-lock-and-wait
61a0: 20 6c 6f 63 6b 2d 66 69 6c 65 20 65 78 70 69 72 lock-file expir
61b0: 65 2d 74 69 6d 65 3a 20 32 35 29 0a 09 20 20 28 e-time: 25).. (
61c0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
61d0: 20 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2 *default-log
61e0: 2d 70 6f 72 74 2a 20 22 73 65 72 76 65 72 3a 6b -port* "server:k
61f0: 69 6e 64 2d 72 75 6e 3a 20 74 6f 75 63 68 69 6e ind-run: touchin
6200: 67 20 22 20 73 74 61 72 74 2d 66 6c 61 67 29 0a g " start-flag).
6210: 09 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 . (system (conc
6220: 20 22 74 6f 75 63 68 20 22 20 73 74 61 72 74 2d "touch " start-
6230: 66 6c 61 67 29 29 20 3b 3b 20 6c 61 7a 79 20 62 flag)) ;; lazy b
6240: 75 74 20 73 61 66 65 0a 09 20 20 28 73 65 72 76 ut safe.. (serv
6250: 65 72 3a 72 75 6e 20 61 72 65 61 70 61 74 68 29 er:run areapath)
6260: 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
6270: 70 21 20 32 30 29 20 3b 3b 20 64 6f 6e 27 74 20 p! 20) ;; don't
6280: 72 65 6c 65 61 73 65 20 74 68 65 20 6c 6f 63 6b release the lock
6290: 20 66 6f 72 20 61 74 20 6c 65 61 73 74 20 61 20 for at least a
62a0: 66 65 77 20 73 65 63 6f 6e 64 73 2e 20 41 6e 64 few seconds. And
62b0: 20 61 6c 6c 6f 77 20 74 69 6d 65 20 66 6f 72 20 allow time for
62c0: 74 68 65 20 73 65 72 76 65 72 20 73 74 61 72 74 the server start
62d0: 75 70 20 74 6f 20 67 65 74 20 74 6f 20 22 53 45 up to get to "SE
62e0: 52 56 45 52 20 53 54 41 52 54 45 44 22 2e 0a 09 RVER STARTED"...
62f0: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 (common:simple
6300: 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f -file-release-lo
6310: 63 6b 20 6c 6f 63 6b 2d 66 69 6c 65 29 29 29 0a ck lock-file))).
6320: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
6330: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
6340: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 6f lt-log-port* "Fo
6350: 75 6e 64 20 73 65 72 76 65 72 20 61 6c 72 65 61 und server alrea
6360: 64 79 20 72 75 6e 6e 69 6e 67 2e 20 4e 4f 54 20 dy running. NOT
6370: 74 72 79 69 6e 67 20 74 6f 20 73 74 61 72 74 20 trying to start
6380: 61 6e 6f 74 68 65 72 2e 22 29 29 29 0a 0a 3b 3b another.")))..;;
6390: 20 74 68 69 73 20 6f 6e 65 20 73 65 65 6d 73 20 this one seems
63a0: 74 6f 20 62 65 20 74 68 65 20 67 65 6e 65 72 61 to be the genera
63b0: 6c 20 65 6e 74 72 79 20 70 6f 69 6e 74 0a 3b 3b l entry point.;;
63c0: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
63d0: 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 20 :start-and-wait
63e0: 61 72 65 61 70 61 74 68 20 23 21 6b 65 79 20 28 areapath #!key (
63f0: 74 69 6d 65 6f 75 74 20 36 30 29 29 0a 20 20 28 timeout 60)). (
6400: 6c 65 74 20 28 28 67 69 76 65 2d 75 70 2d 74 69 let ((give-up-ti
6410: 6d 65 20 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 me (+ (current-s
6420: 65 63 6f 6e 64 73 29 20 74 69 6d 65 6f 75 74 29 econds) timeout)
6430: 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 )). (let loop
6440: 20 28 28 73 65 72 76 65 72 2d 69 6e 66 6f 20 28 ((server-info (
6450: 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d server:check-if-
6460: 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 61 74 68 running areapath
6470: 29 29 0a 09 20 20 20 20 20 20 20 28 74 72 79 2d )).. (try-
6480: 6e 75 6d 20 20 20 20 30 29 29 0a 20 20 20 20 20 num 0)).
6490: 20 28 69 66 20 28 6f 72 20 73 65 72 76 65 72 2d (if (or server-
64a0: 69 6e 66 6f 0a 09 20 20 20 20 20 20 28 3e 20 28 info.. (> (
64b0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
64c0: 20 67 69 76 65 2d 75 70 2d 74 69 6d 65 29 29 20 give-up-time))
64d0: 3b 3b 20 73 65 72 76 65 72 2d 75 72 6c 20 77 69 ;; server-url wi
64e0: 6c 6c 20 62 65 20 23 66 20 69 66 20 6e 6f 20 73 ll be #f if no s
64f0: 65 72 76 65 72 20 61 76 61 69 6c 61 62 6c 65 2e erver available.
6500: 0a 09 20 20 28 73 65 72 76 65 72 3a 72 65 63 6f .. (server:reco
6510: 72 64 2d 3e 75 72 6c 20 73 65 72 76 65 72 2d 69 rd->url server-i
6520: 6e 66 6f 29 0a 09 20 20 28 6c 65 74 2a 20 28 20 nfo).. (let* (
6530: 28 73 65 72 76 65 72 73 20 28 73 65 72 76 65 72 (servers (server
6540: 3a 63 68 6f 6f 73 65 2d 73 65 72 76 65 72 20 61 :choose-server a
6550: 72 65 61 70 61 74 68 20 27 61 6c 6c 2d 76 61 6c reapath 'all-val
6560: 69 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 id)).
6570: 20 20 20 20 20 28 6e 75 6d 2d 6f 6b 20 28 69 66 (num-ok (if
6580: 20 73 65 72 76 65 72 73 20 28 6c 65 6e 67 74 68 servers (length
6590: 20 28 73 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d (server:choose-
65a0: 73 65 72 76 65 72 20 61 72 65 61 70 61 74 68 20 server areapath
65b0: 27 61 6c 6c 2d 76 61 6c 69 64 29 29 20 30 29 29 'all-valid)) 0))
65c0: 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 ).. (if (and
65d0: 28 3e 20 74 72 79 2d 6e 75 6d 20 30 29 20 20 3b (> try-num 0) ;
65e0: 3b 20 66 69 72 73 74 20 74 69 6d 65 20 74 68 72 ; first time thr
65f0: 6f 75 67 68 20 73 69 6d 70 6c 79 20 77 61 69 74 ough simply wait
6600: 20 61 20 6c 69 74 74 6c 65 20 77 68 69 6c 65 20 a little while
6610: 74 68 65 6e 20 74 72 79 20 61 67 61 69 6e 0a 09 then try again..
6620: 09 20 20 20 20 20 28 3c 20 6e 75 6d 2d 6f 6b 20 . (< num-ok
6630: 31 29 29 20 20 3b 3b 20 69 66 20 74 68 65 72 65 1)) ;; if there
6640: 20 61 72 65 20 6e 6f 20 64 65 63 65 6e 74 20 63 are no decent c
6650: 61 6e 64 69 64 61 74 65 73 20 66 6f 72 20 73 65 andidates for se
6660: 72 76 65 72 73 20 74 68 65 6e 20 74 72 79 20 73 rvers then try s
6670: 74 61 72 74 69 6e 67 20 61 20 6e 65 77 20 6f 6e tarting a new on
6680: 65 0a 09 09 28 73 65 72 76 65 72 3a 72 75 6e 20 e...(server:run
6690: 61 72 65 61 70 61 74 68 29 29 0a 09 20 20 20 20 areapath))..
66a0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 (thread-sleep! 5
66b0: 29 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 73 65 ).. (loop (se
66c0: 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 rver:check-if-ru
66d0: 6e 6e 69 6e 67 20 61 72 65 61 70 61 74 68 29 0a nning areapath).
66e0: 09 09 20 20 28 2b 20 74 72 79 2d 6e 75 6d 20 31 .. (+ try-num 1
66f0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
6700: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6e 75 6d (server:get-num
6710: 2d 73 65 72 76 65 72 73 20 23 21 6b 65 79 20 28 -servers #!key (
6720: 6e 75 6d 73 65 72 76 65 72 73 20 32 29 29 0a 20 numservers 2)).
6730: 20 28 6c 65 74 20 28 28 6e 73 20 28 73 74 72 69 (let ((ns (stri
6740: 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 20 20 20 ng->number..
6750: 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (or (configf:lo
6760: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
6770: 20 22 73 65 72 76 65 72 22 20 22 6e 75 6d 73 65 "server" "numse
6780: 72 76 65 72 73 22 29 20 22 6e 6f 74 61 6e 75 6d rvers") "notanum
6790: 62 65 72 22 29 29 29 29 0a 20 20 20 20 28 6f 72 ber")))). (or
67a0: 20 6e 73 20 6e 75 6d 73 65 72 76 65 72 73 29 29 ns numservers))
67b0: 29 0a 0a 3b 3b 20 6e 6f 20 6c 6f 6e 67 65 72 20 )..;; no longer
67c0: 63 61 72 65 20 69 66 20 6d 75 6c 74 69 70 6c 65 care if multiple
67d0: 20 73 65 72 76 65 72 73 20 61 72 65 20 73 74 61 servers are sta
67e0: 72 74 65 64 20 62 79 20 61 63 63 69 64 65 6e 74 rted by accident
67f0: 2e 20 6f 6c 64 65 72 20 73 65 72 76 65 72 73 20 . older servers
6800: 77 69 6c 6c 20 64 72 6f 70 20 6f 66 66 20 69 6e will drop off in
6810: 20 74 69 6d 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e time..;;.(defin
6820: 65 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d e (server:check-
6830: 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 if-running areap
6840: 61 74 68 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 ath) ;; #!key (
6850: 6e 75 6d 73 65 72 76 65 72 73 20 22 32 22 29 29 numservers "2"))
6860: 0a 20 20 28 6c 65 74 2a 20 28 28 6e 73 20 20 20 . (let* ((ns
6870: 20 20 20 20 20 20 20 20 20 28 73 65 72 76 65 72 (server
6880: 3a 67 65 74 2d 6e 75 6d 2d 73 65 72 76 65 72 73 :get-num-servers
6890: 29 29 20 3b 3b 20 67 65 74 20 74 68 65 20 73 65 )) ;; get the se
68a0: 74 74 69 6e 67 20 74 68 65 20 66 6f 72 20 6d 61 tting the for ma
68b0: 78 69 6d 75 6d 20 6e 75 6d 62 65 72 20 6f 66 20 ximum number of
68c0: 73 65 72 76 65 72 73 20 61 6c 6c 6f 77 65 64 0a servers allowed.
68d0: 09 20 28 73 65 72 76 65 72 73 20 20 20 20 20 20 . (servers
68e0: 20 28 73 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d (server:choose-
68f0: 73 65 72 76 65 72 20 61 72 65 61 70 61 74 68 20 server areapath
6900: 27 62 65 73 74 2d 74 65 6e 29 29 29 20 3b 3b 20 'best-ten))) ;;
6910: 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 (server:get-best
6920: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6c 69 73 (server:get-lis
6930: 74 20 61 72 65 61 70 61 74 68 29 29 29 29 0a 20 t areapath)))).
6940: 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 (if (or (and
6950: 73 65 72 76 65 72 73 0a 09 09 20 28 6e 75 6c 6c servers... (null
6960: 3f 20 73 65 72 76 65 72 73 29 29 0a 09 20 20 20 ? servers))..
6970: 20 28 6e 6f 74 20 73 65 72 76 65 72 73 29 29 0a (not servers)).
6980: 09 20 20 20 20 3b 3b 20 28 61 6e 64 20 28 6c 69 . ;; (and (li
6990: 73 74 3f 20 73 65 72 76 65 72 73 29 0a 09 20 20 st? servers)..
69a0: 20 20 3b 3b 09 20 28 3c 20 28 6c 65 6e 67 74 68 ;;. (< (length
69b0: 20 73 65 72 76 65 72 73 29 20 28 2b 20 31 20 28 servers) (+ 1 (
69c0: 72 61 6e 64 6f 6d 20 6e 73 29 29 29 29 29 20 3b random ns))))) ;
69d0: 3b 20 73 6f 6d 65 77 68 65 72 65 20 62 65 74 77 ; somewhere betw
69e0: 65 65 6e 20 31 20 61 6e 64 20 6e 75 6d 73 65 72 een 1 and numser
69f0: 76 65 72 73 0a 20 20 20 20 20 20 20 20 23 66 0a vers. #f.
6a00: 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f (let loo
6a10: 70 20 28 28 68 65 64 20 28 63 61 72 20 73 65 72 p ((hed (car ser
6a20: 76 65 72 73 29 29 0a 20 20 20 20 20 20 20 20 20 vers)).
6a30: 20 20 20 20 20 20 20 20 20 20 28 74 61 6c 20 28 (tal (
6a40: 63 64 72 20 73 65 72 76 65 72 73 29 29 29 0a 20 cdr servers))).
6a50: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
6a60: 72 65 73 20 28 73 65 72 76 65 72 3a 63 68 65 63 res (server:chec
6a70: 6b 2d 73 65 72 76 65 72 20 68 65 64 29 29 29 0a k-server hed))).
6a80: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
6a90: 72 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 res.
6aa0: 20 20 20 20 68 65 64 0a 20 20 20 20 20 20 20 20 hed.
6ab0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c (if (nul
6ac0: 6c 3f 20 74 61 6c 29 0a 20 20 20 20 20 20 20 20 l? tal).
6ad0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 0a 20 #f.
6ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6af0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
6b00: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
6b10: 29 29 29 0a 0a 3b 3b 20 70 69 6e 67 20 74 68 65 )))..;; ping the
6b20: 20 67 69 76 65 6e 20 73 65 72 76 65 72 0a 3b 3b given server.;;
6b30: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
6b40: 3a 63 68 65 63 6b 2d 73 65 72 76 65 72 20 73 65 :check-server se
6b50: 72 76 65 72 2d 72 65 63 6f 72 64 29 0a 20 20 28 rver-record). (
6b60: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 75 72 let* ((server-ur
6b70: 6c 20 28 73 65 72 76 65 72 3a 72 65 63 6f 72 64 l (server:record
6b80: 2d 3e 75 72 6c 20 73 65 72 76 65 72 2d 72 65 63 ->url server-rec
6b90: 6f 72 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 ord)). (
6ba0: 73 65 72 76 65 72 2d 69 64 20 20 28 73 65 72 76 server-id (serv
6bb0: 65 72 3a 72 65 63 6f 72 64 2d 3e 69 64 20 73 65 er:record->id se
6bc0: 72 76 65 72 2d 72 65 63 6f 72 64 29 29 20 0a 20 rver-record)) .
6bd0: 20 20 20 20 20 20 20 20 28 72 65 73 20 20 20 20 (res
6be0: 20 20 20 20 28 73 65 72 76 65 72 3a 70 69 6e 67 (server:ping
6bf0: 20 73 65 72 76 65 72 2d 75 72 6c 20 73 65 72 76 server-url serv
6c00: 65 72 2d 69 64 29 29 29 0a 20 20 20 20 28 69 66 er-id))). (if
6c10: 20 72 65 73 0a 20 20 20 20 20 20 20 20 73 65 72 res. ser
6c20: 76 65 72 2d 75 72 6c 0a 09 23 66 29 29 29 0a 0a ver-url..#f)))..
6c30: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
6c40: 6b 69 6c 6c 20 73 65 72 76 72 29 0a 20 20 28 68 kill servr). (h
6c50: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
6c60: 0a 20 20 20 20 65 78 6e 0a 20 20 20 20 28 62 65 . exn. (be
6c70: 67 69 6e 20 0a 20 20 20 20 20 20 28 64 65 62 75 gin . (debu
6c80: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
6c90: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6ca0: 2a 20 20 22 55 6e 61 62 6c 65 20 74 6f 20 67 65 * "Unable to ge
6cb0: 74 20 68 6f 73 74 20 61 6e 64 2f 6f 72 20 70 6f t host and/or po
6cc0: 72 74 20 66 72 6f 6d 20 22 20 73 65 72 76 72 20 rt from " servr
6cd0: 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 20 20 20 ", exn=" exn)
6ce0: 20 20 0a 20 20 20 20 23 66 29 0a 20 20 28 6d 61 . #f). (ma
6cf0: 74 63 68 2d 6c 65 74 20 28 28 28 68 6f 73 74 6e tch-let (((hostn
6d00: 61 6d 65 20 70 6f 72 74 20 73 74 61 72 74 2d 74 ame port start-t
6d10: 69 6d 65 20 73 65 72 76 65 72 2d 69 64 20 70 69 ime server-id pi
6d20: 64 29 0a 09 20 20 20 20 20 20 20 73 65 72 76 72 d).. servr
6d30: 29 29 0a 20 20 20 20 28 74 61 73 6b 73 3a 6b 69 )). (tasks:ki
6d40: 6c 6c 2d 73 65 72 76 65 72 20 68 6f 73 74 6e 61 ll-server hostna
6d50: 6d 65 20 70 69 64 29 29 29 29 0a 0a 3b 3b 20 63 me pid))))..;; c
6d60: 61 6c 6c 65 64 20 69 6e 20 6d 65 67 61 74 65 73 alled in megates
6d70: 74 2e 73 63 6d 2c 20 68 6f 73 74 2d 70 6f 72 74 t.scm, host-port
6d80: 20 69 73 20 73 74 72 69 6e 67 20 68 6f 73 74 6e is string hostn
6d90: 61 6d 65 3a 70 6f 72 74 0a 3b 3b 0a 3b 3b 20 4e ame:port.;;.;; N
6da0: 4f 54 45 3a 20 54 68 69 73 20 69 73 20 4e 4f 54 OTE: This is NOT
6db0: 20 63 61 6c 6c 65 64 20 64 69 72 65 63 74 6c 79 called directly
6dc0: 20 66 72 6f 6d 20 63 6c 69 65 6e 74 73 20 61 73 from clients as
6dd0: 20 6e 6f 74 20 61 6c 6c 20 74 72 61 6e 73 70 6f not all transpo
6de0: 72 74 73 20 73 75 70 70 6f 72 74 20 61 20 63 6c rts support a cl
6df0: 69 65 6e 74 20 72 75 6e 6e 69 6e 67 0a 3b 3b 20 ient running.;;
6e00: 20 20 20 20 20 20 69 6e 20 74 68 65 20 73 61 6d in the sam
6e10: 65 20 70 72 6f 63 65 73 73 20 61 73 20 74 68 65 e process as the
6e20: 20 73 65 72 76 65 72 2e 0a 3b 3b 0a 28 64 65 66 server..;;.(def
6e30: 69 6e 65 20 28 73 65 72 76 65 72 3a 70 69 6e 67 ine (server:ping
6e40: 20 68 6f 73 74 3a 70 6f 72 74 20 73 65 72 76 65 host:port serve
6e50: 72 2d 69 64 20 23 21 6b 65 79 20 28 64 6f 2d 65 r-id #!key (do-e
6e60: 78 69 74 20 23 66 29 29 0a 20 20 28 6c 65 74 2a xit #f)). (let*
6e70: 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 28 63 6f ((host-port (co
6e80: 6e 64 0a 09 09 20 20 20 20 20 28 28 73 74 72 69 nd... ((stri
6e90: 6e 67 3f 20 68 6f 73 74 3a 70 6f 72 74 29 0a 09 ng? host:port)..
6ea0: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 6c . (let ((sl
6eb0: 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 st (string-split
6ec0: 20 20 20 68 6f 73 74 3a 70 6f 72 74 20 22 3a 22 host:port ":"
6ed0: 29 29 29 0a 09 09 09 28 69 66 20 28 65 71 3f 20 )))....(if (eq?
6ee0: 28 6c 65 6e 67 74 68 20 73 6c 73 74 29 20 32 29 (length slst) 2)
6ef0: 0a 09 09 09 20 20 20 20 28 6c 69 73 74 20 28 63 .... (list (c
6f00: 61 72 20 73 6c 73 74 29 28 73 74 72 69 6e 67 2d ar slst)(string-
6f10: 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 73 6c >number (cadr sl
6f20: 73 74 29 29 29 0a 09 09 09 20 20 20 20 23 66 29 st))).... #f)
6f30: 29 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 0a ))... (else.
6f40: 09 09 20 20 20 20 20 20 23 66 29 29 29 29 0a 20 .. #f)))).
6f50: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
6f60: 61 6e 64 20 28 6c 69 73 74 3f 20 68 6f 73 74 2d and (list? host-
6f70: 70 6f 72 74 29 0a 09 20 20 20 28 65 71 3f 20 28 port).. (eq? (
6f80: 6c 65 6e 67 74 68 20 68 6f 73 74 2d 70 6f 72 74 length host-port
6f90: 29 20 32 29 29 0a 20 20 20 20 20 20 28 6c 65 74 ) 2)). (let
6fa0: 2a 20 28 28 6d 79 72 75 6e 72 65 6d 6f 74 65 20 * ((myrunremote
6fb0: 28 6d 61 6b 65 2d 61 6e 64 2d 69 6e 69 74 2d 72 (make-and-init-r
6fc0: 65 6d 6f 74 65 20 2a 74 6f 70 70 61 74 68 2a 29 emote *toppath*)
6fd0: 29 0a 09 20 20 20 20 20 28 69 66 61 63 65 20 20 ).. (iface
6fe0: 20 20 20 20 20 28 63 61 72 20 68 6f 73 74 2d 70 (car host-p
6ff0: 6f 72 74 29 29 0a 09 20 20 20 20 20 28 70 6f 72 ort)).. (por
7000: 74 20 20 20 20 20 20 20 20 28 63 61 64 72 20 68 t (cadr h
7010: 6f 73 74 2d 70 6f 72 74 29 29 0a 09 20 20 20 20 ost-port))..
7020: 20 28 73 65 72 76 65 72 2d 64 61 74 20 20 28 63 (server-dat (c
7030: 6c 69 65 6e 74 3a 63 6f 6e 6e 65 63 74 20 69 66 lient:connect if
7040: 61 63 65 20 70 6f 72 74 20 73 65 72 76 65 72 2d ace port server-
7050: 69 64 20 6d 79 72 75 6e 72 65 6d 6f 74 65 29 29 id myrunremote))
7060: 0a 09 20 20 20 20 20 28 6c 6f 67 69 6e 2d 72 65 .. (login-re
7070: 73 20 20 20 28 72 6d 74 3a 6c 6f 67 69 6e 2d 6e s (rmt:login-n
7080: 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 o-auto-client-se
7090: 74 75 70 20 6d 79 72 75 6e 72 65 6d 6f 74 65 29 tup myrunremote)
70a0: 29 29 0a 09 28 68 74 74 70 2d 74 72 61 6e 73 70 ))..(http-transp
70b0: 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 ort:close-connec
70c0: 74 69 6f 6e 73 20 6d 79 72 75 6e 72 65 6d 6f 74 tions myrunremot
70d0: 65 29 0a 09 28 69 66 20 28 61 6e 64 20 28 6c 69 e)..(if (and (li
70e0: 73 74 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 0a 09 st? login-res)..
70f0: 09 20 28 63 61 72 20 6c 6f 67 69 6e 2d 72 65 73 . (car login-res
7100: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )).. (begin..
7110: 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ;; (print
7120: 22 4c 4f 47 49 4e 5f 4f 4b 22 29 0a 09 20 20 20 "LOGIN_OK")..
7130: 20 20 20 28 69 66 20 64 6f 2d 65 78 69 74 20 28 (if do-exit (
7140: 65 78 69 74 20 30 29 29 0a 09 20 20 20 20 20 20 exit 0))..
7150: 23 74 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a #t).. (begin.
7160: 09 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 . ;; (print
7170: 20 22 4c 4f 47 49 4e 5f 46 41 49 4c 45 44 22 29 "LOGIN_FAILED")
7180: 0a 09 20 20 20 20 20 20 28 69 66 20 64 6f 2d 65 .. (if do-e
7190: 78 69 74 20 28 65 78 69 74 20 31 29 29 0a 09 20 xit (exit 1))..
71a0: 20 20 20 20 20 23 66 29 29 29 29 0a 20 20 20 20 #f)))).
71b0: 20 28 65 6c 73 65 20 0a 20 20 20 20 20 20 28 69 (else . (i
71c0: 66 20 68 6f 73 74 3a 70 6f 72 74 0a 09 20 20 28 f host:port.. (
71d0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
71e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
71f0: 20 20 22 45 52 52 4f 52 3a 20 62 61 64 20 68 6f "ERROR: bad ho
7200: 73 74 3a 70 6f 72 74 20 22 68 6f 73 74 3a 70 6f st:port "host:po
7210: 72 74 29 29 0a 20 20 20 20 20 20 28 69 66 20 64 rt)). (if d
7220: 6f 2d 65 78 69 74 0a 09 20 20 28 65 78 69 74 20 o-exit.. (exit
7230: 31 29 0a 09 20 20 23 66 29 29 29 29 29 0a 0a 3b 1).. #f)))))..;
7240: 3b 20 72 75 6e 20 70 69 6e 67 20 69 6e 20 73 65 ; run ping in se
7250: 70 61 72 61 74 65 20 70 72 6f 63 65 73 73 2c 20 parate process,
7260: 73 61 66 65 73 74 20 77 61 79 20 69 6e 20 73 6f safest way in so
7270: 6d 65 20 63 61 73 65 73 0a 3b 3b 0a 28 64 65 66 me cases.;;.(def
7280: 69 6e 65 20 28 73 65 72 76 65 72 3a 70 69 6e 67 ine (server:ping
7290: 2d 73 65 72 76 65 72 20 69 66 61 63 65 70 6f 72 -server ifacepor
72a0: 74 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 t). (with-input
72b0: 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 28 -from-pipe . (
72c0: 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 conc (common:get
72d0: 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 29 20 22 -megatest-exe) "
72e0: 20 2d 70 69 6e 67 20 22 20 69 66 61 63 65 70 6f -ping " ifacepo
72f0: 72 74 29 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 rt). (lambda (
7300: 29 0a 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 ). (let loop
7310: 20 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e ((inl (read-lin
7320: 65 29 29 0a 09 09 28 72 65 73 20 22 4e 4f 52 45 e))...(res "NORE
7330: 50 4c 59 22 29 29 0a 20 20 20 20 20 20 20 28 69 PLY")). (i
7340: 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 f (eof-object? i
7350: 6e 6c 29 0a 09 20 20 20 28 63 61 73 65 20 28 73 nl).. (case (s
7360: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 72 65 tring->symbol re
7370: 73 29 0a 09 20 20 20 20 20 28 28 4e 4f 52 45 50 s).. ((NOREP
7380: 4c 59 29 20 20 23 66 29 0a 09 20 20 20 20 20 28 LY) #f).. (
7390: 28 4c 4f 47 49 4e 5f 4f 4b 29 20 23 74 29 0a 09 (LOGIN_OK) #t)..
73a0: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
73b0: 20 23 66 29 29 0a 09 20 20 20 28 6c 6f 6f 70 20 #f)).. (loop
73c0: 28 72 65 61 64 2d 6c 69 6e 65 29 20 69 6e 6c 29 (read-line) inl)
73d0: 29 29 29 29 29 0a 0a 3b 3b 20 4e 4f 54 20 55 53 )))))..;; NOT US
73e0: 45 44 20 28 77 65 6c 6c 2c 20 6f 6b 2c 20 72 65 ED (well, ok, re
73f0: 66 65 72 65 6e 63 65 20 69 6e 20 72 70 63 2d 74 ference in rpc-t
7400: 72 61 6e 73 70 6f 72 74 20 62 75 74 20 6f 74 68 ransport but oth
7410: 65 72 77 69 73 65 20 6e 6f 74 20 75 73 65 64 29 erwise not used)
7420: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 ..;;.(define (se
7430: 72 76 65 72 3a 6c 6f 67 69 6e 20 74 6f 70 70 61 rver:login toppa
7440: 74 68 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 74 th). (lambda (t
7450: 6f 70 70 61 74 68 29 0a 20 20 20 20 28 73 65 74 oppath). (set
7460: 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 ! *db-last-acces
7470: 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f s* (current-seco
7480: 6e 64 73 29 29 20 3b 3b 20 6d 69 67 68 74 20 6e nds)) ;; might n
7490: 6f 74 20 62 65 20 6e 65 65 64 65 64 2e 0a 20 20 ot be needed..
74a0: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 2a 74 (if (equal? *t
74b0: 6f 70 70 61 74 68 2a 20 74 6f 70 70 61 74 68 29 oppath* toppath)
74c0: 0a 09 23 74 0a 09 23 66 29 29 29 0a 0a 3b 3b 20 ..#t..#f)))..;;
74d0: 74 69 6d 65 6f 75 74 20 69 73 20 68 6d 73 20 73 timeout is hms s
74e0: 74 72 69 6e 67 3a 20 31 68 20 35 6d 20 33 73 2c tring: 1h 5m 3s,
74f0: 20 64 65 66 61 75 6c 74 20 69 73 20 31 20 6d 69 default is 1 mi
7500: 6e 75 74 65 0a 3b 3b 20 54 68 69 73 20 69 73 20 nute.;; This is
7510: 63 75 72 72 65 6e 74 6c 79 20 62 72 6f 6b 65 6e currently broken
7520: 2e 20 4a 75 73 74 20 75 73 65 20 74 68 65 20 6e . Just use the n
7530: 75 6d 62 65 72 20 6f 66 20 68 6f 75 72 73 20 77 umber of hours w
7540: 69 74 68 20 6e 6f 20 75 6e 69 74 2e 0a 3b 3b 20 ith no unit..;;
7550: 44 65 66 61 75 6c 74 20 69 73 20 36 30 20 73 65 Default is 60 se
7560: 63 6f 6e 64 73 2e 0a 3b 3b 0a 28 64 65 66 69 6e conds..;;.(defin
7570: 65 20 28 73 65 72 76 65 72 3a 65 78 70 69 72 61 e (server:expira
7580: 74 69 6f 6e 2d 74 69 6d 65 6f 75 74 29 0a 20 20 tion-timeout).
7590: 28 6c 65 74 20 28 28 74 6d 6f 20 28 63 6f 6e 66 (let ((tmo (conf
75a0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
75b0: 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 igdat* "server"
75c0: 22 74 69 6d 65 6f 75 74 22 29 29 29 0a 20 20 20 "timeout"))).
75d0: 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e (if (and (strin
75e0: 67 3f 20 74 6d 6f 29 0a 09 20 20 20 20 20 28 63 g? tmo).. (c
75f0: 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 72 69 6e 67 ommon:hms-string
7600: 2d 3e 73 65 63 6f 6e 64 73 20 74 6d 6f 29 29 20 ->seconds tmo))
7610: 3b 3b 20 42 55 47 3a 20 68 6d 73 2d 73 74 72 69 ;; BUG: hms-stri
7620: 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 69 73 20 62 ng->seconds is b
7630: 72 6f 6b 65 6e 2c 20 69 66 20 67 69 76 65 6e 20 roken, if given
7640: 22 31 30 22 20 72 65 74 75 72 6e 73 20 30 2e 20 "10" returns 0.
7650: 41 6c 73 6f 2c 20 69 74 20 64 6f 65 73 6e 27 74 Also, it doesn't
7660: 20 62 65 6c 6f 6e 67 20 69 6e 20 74 68 69 73 20 belong in this
7670: 6c 6f 67 69 63 20 75 6e 6c 65 73 73 20 74 68 65 logic unless the
7680: 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 string->number
7690: 69 73 20 63 68 61 6e 67 65 64 20 62 65 6c 6f 77 is changed below
76a0: 0a 20 20 20 20 20 20 20 20 28 2a 20 33 36 30 30 . (* 3600
76b0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
76c0: 20 74 6d 6f 29 29 0a 09 36 30 30 29 29 29 0a 0a tmo))..600)))..
76d0: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
76e0: 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 get-best-guess-a
76f0: 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 ddress hostname)
7700: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
7710: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
7720: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
7730: 61 64 72 29 0a 20 20 20 20 20 20 20 28 69 66 20 adr). (if
7740: 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 (not (eq? (u8vec
7750: 74 6f 72 2d 72 65 66 20 61 64 72 20 30 29 20 31 tor-ref adr 0) 1
7760: 32 37 29 29 0a 09 20 20 20 28 73 65 74 21 20 72 27)).. (set! r
7770: 65 73 20 61 64 72 29 29 29 0a 20 20 20 20 20 3b es adr))). ;
7780: 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 63 61 6e ; NOTE: This can
7790: 20 66 61 69 6c 20 77 68 65 6e 20 74 68 65 72 65 fail when there
77a0: 20 69 73 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 6f is no mention o
77b0: 66 20 74 68 65 20 68 6f 73 74 20 69 6e 20 2f 65 f the host in /e
77c0: 74 63 2f 68 6f 73 74 73 2e 20 46 49 58 4d 45 0a tc/hosts. FIXME.
77d0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c 69 (vector->li
77e0: 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 st (hostinfo-add
77f0: 72 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d 65 resses (hostname
7800: 2d 3e 68 6f 73 74 69 6e 66 6f 20 68 6f 73 74 6e ->hostinfo hostn
7810: 61 6d 65 29 29 29 29 0a 20 20 20 20 28 73 74 72 ame)))). (str
7820: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
7830: 0a 20 20 20 20 20 28 6d 61 70 20 6e 75 6d 62 65 . (map numbe
7840: 72 2d 3e 73 74 72 69 6e 67 0a 09 20 20 28 75 38 r->string.. (u8
7850: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 20 vector->list..
7860: 20 28 69 66 20 72 65 73 20 72 65 73 20 28 68 6f (if res res (ho
7870: 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e stname->ip hostn
7880: 61 6d 65 29 29 29 29 20 22 2e 22 29 29 29 0a 0a ame)))) ".")))..
7890: 3b 3b 20 28 64 65 66 69 6e 65 20 73 65 72 76 65 ;; (define serve
78a0: 72 3a 73 79 6e 63 2d 6c 6f 63 6b 2d 74 6f 6b 65 r:sync-lock-toke
78b0: 6e 20 22 53 45 52 56 45 52 5f 53 59 4e 43 5f 4c n "SERVER_SYNC_L
78c0: 4f 43 4b 22 29 0a 3b 3b 20 28 64 65 66 69 6e 65 OCK").;; (define
78d0: 20 28 73 65 72 76 65 72 3a 72 65 6c 65 61 73 65 (server:release
78e0: 2d 73 79 6e 63 2d 6c 6f 63 6b 29 0a 3b 3b 20 20 -sync-lock).;;
78f0: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c (db:no-sync-del
7900: 21 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 73 ! *no-sync-db* s
7910: 65 72 76 65 72 3a 73 79 6e 63 2d 6c 6f 63 6b 2d erver:sync-lock-
7920: 74 6f 6b 65 6e 29 29 0a 3b 3b 20 28 64 65 66 69 token)).;; (defi
7930: 6e 65 20 28 73 65 72 76 65 72 3a 68 61 76 65 2d ne (server:have-
7940: 73 79 6e 63 2d 6c 6f 63 6b 3f 29 0a 3b 3b 20 20 sync-lock?).;;
7950: 20 28 6c 65 74 2a 20 28 28 68 61 76 65 2d 6c 6f (let* ((have-lo
7960: 63 6b 2d 70 61 69 72 20 28 64 62 3a 6e 6f 2d 73 ck-pair (db:no-s
7970: 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 2a 6e 6f ync-get-lock *no
7980: 2d 73 79 6e 63 2d 64 62 2a 20 73 65 72 76 65 72 -sync-db* server
7990: 3a 73 79 6e 63 2d 6c 6f 63 6b 2d 74 6f 6b 65 6e :sync-lock-token
79a0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 )).;; (
79b0: 68 61 76 65 2d 6c 6f 63 6b 3f 20 20 20 20 20 28 have-lock? (
79c0: 63 61 72 20 68 61 76 65 2d 6c 6f 63 6b 2d 70 61 car have-lock-pa
79d0: 69 72 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ir)).;;
79e0: 20 28 6c 6f 63 6b 2d 74 69 6d 65 20 20 20 20 20 (lock-time
79f0: 20 28 63 64 72 20 68 61 76 65 2d 6c 6f 63 6b 2d (cdr have-lock-
7a00: 70 61 69 72 29 29 0a 3b 3b 20 20 20 20 20 20 20 pair)).;;
7a10: 20 20 20 28 6c 6f 63 6b 2d 61 67 65 20 20 20 20 (lock-age
7a20: 20 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (- (current-s
7a30: 65 63 6f 6e 64 73 29 20 6c 6f 63 6b 2d 74 69 6d econds) lock-tim
7a40: 65 29 29 29 0a 3b 3b 20 20 20 20 20 28 63 6f 6e e))).;; (con
7a50: 64 0a 3b 3b 20 20 20 20 20 20 28 68 61 76 65 2d d.;; (have-
7a60: 6c 6f 63 6b 3f 20 23 74 29 0a 3b 3b 20 20 20 20 lock? #t).;;
7a70: 20 20 28 28 3e 6c 6f 63 6b 2d 61 67 65 0a 3b 3b ((>lock-age.;;
7a80: 20 20 20 20 20 20 20 20 28 2a 20 33 20 28 63 6f (* 3 (co
7a90: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d nfigf:lookup-num
7aa0: 62 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 ber *configdat*
7ab0: 22 73 65 72 76 65 72 22 20 22 6d 69 6e 69 6d 75 "server" "minimu
7ac0: 6d 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 m-intersync-dela
7ad0: 79 22 20 64 65 66 61 75 6c 74 3a 20 31 38 30 29 y" default: 180)
7ae0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 73 65 72 )).;; (ser
7af0: 76 65 72 3a 72 65 6c 65 61 73 65 2d 73 79 6e 63 ver:release-sync
7b00: 2d 6c 6f 63 6b 29 0a 3b 3b 20 20 20 20 20 20 20 -lock).;;
7b10: 28 73 65 72 76 65 72 3a 68 61 76 65 2d 73 79 6e (server:have-syn
7b20: 63 2d 6c 6f 63 6b 3f 29 29 0a 3b 3b 20 20 20 20 c-lock?)).;;
7b30: 20 20 28 65 6c 73 65 20 23 66 29 29 29 29 0a 0a (else #f))))..
7b40: 3b 3b 20 6d 6f 76 69 6e 67 20 74 68 69 73 20 68 ;; moving this h
7b50: 65 72 65 20 61 73 20 69 74 20 6e 65 65 64 73 20 ere as it needs
7b60: 61 63 63 65 73 73 20 74 6f 20 64 62 20 61 6e 64 access to db and
7b70: 20 63 61 6e 6e 6f 74 20 62 65 20 69 6e 20 63 6f cannot be in co
7b80: 6d 6d 6f 6e 2e 0a 3b 3b 0a 0a 28 64 65 66 69 6e mmon..;;..(defin
7b90: 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 72 e (server:get-br
7ba0: 75 74 65 66 6f 72 63 65 2d 73 79 6e 63 65 72 20 uteforce-syncer
7bb0: 64 62 73 74 72 75 63 74 20 23 21 6b 65 79 20 28 dbstruct #!key (
7bc0: 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 6f 75 fork-to-backgrou
7bd0: 6e 64 20 23 66 29 20 28 70 65 72 73 69 73 74 2d nd #f) (persist-
7be0: 75 6e 74 69 6c 2d 73 79 6e 63 20 23 66 29 29 0a until-sync #f)).
7bf0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 22 (debug:print "
7c00: 57 41 52 4e 49 4e 47 3a 20 62 72 75 74 65 66 6f WARNING: brutefo
7c10: 72 63 65 2d 73 79 6e 63 65 72 20 69 73 20 63 61 rce-syncer is ca
7c20: 6c 6c 65 64 20 62 75 74 20 68 61 73 20 62 65 65 lled but has bee
7c30: 6e 20 64 69 73 61 62 6c 65 64 21 22 29 0a 20 20 n disabled!").
7c40: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 28 (lambda (). (
7c50: 64 65 62 75 67 3a 70 72 69 6e 74 20 22 57 41 52 debug:print "WAR
7c60: 4e 49 4e 47 3a 20 62 72 75 74 65 66 6f 72 63 65 NING: bruteforce
7c70: 2d 73 79 6e 63 65 72 20 69 73 20 63 61 6c 6c 65 -syncer is calle
7c80: 64 20 62 75 74 20 68 61 73 20 62 65 65 6e 20 64 d but has been d
7c90: 69 73 61 62 6c 65 64 21 22 29 29 0a 20 20 23 3b isabled!")). #;
7ca0: 28 6c 65 74 2a 20 28 28 73 71 6c 69 74 65 2d 65 (let* ((sqlite-e
7cb0: 78 65 20 20 20 28 6f 72 20 28 67 65 74 2d 65 6e xe (or (get-en
7cc0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
7cd0: 6c 65 20 22 4d 54 5f 53 51 4c 49 54 45 33 5f 45 le "MT_SQLITE3_E
7ce0: 58 45 22 29 29 29 20 3b 3b 20 64 65 66 69 6e 65 XE"))) ;; define
7cf0: 64 20 69 6e 20 63 66 67 2e 73 68 0a 20 20 20 20 d in cfg.sh.
7d00: 20 20 20 20 20 28 73 79 6e 63 2d 6c 6f 67 20 20 (sync-log
7d10: 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 (or (args:get
7d20: 2d 61 72 67 20 22 2d 73 79 6e 63 2d 6c 6f 67 22 -arg "-sync-log"
7d30: 29 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 ) (conc *toppath
7d40: 2a 20 22 2f 6c 6f 67 73 2f 73 79 6e 63 2d 22 20 * "/logs/sync-"
7d50: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
7d60: 2d 69 64 29 20 22 2d 22 20 28 67 65 74 2d 68 6f -id) "-" (get-ho
7d70: 73 74 2d 6e 61 6d 65 29 20 22 2e 6c 6f 67 22 29 st-name) ".log")
7d80: 29 29 0a 09 20 28 74 6d 70 2d 61 72 65 61 20 20 )).. (tmp-area
7d90: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 (common:get-d
7da0: 62 2d 74 6d 70 2d 61 72 65 61 29 29 0a 09 20 28 b-tmp-area)).. (
7db0: 74 6d 70 2d 64 62 20 20 20 20 20 20 20 28 63 6f tmp-db (co
7dc0: 6e 63 20 74 6d 70 2d 61 72 65 61 20 22 2f 6d 65 nc tmp-area "/me
7dd0: 67 61 74 65 73 74 2e 64 62 22 29 29 0a 09 20 28 gatest.db")).. (
7de0: 73 74 61 67 69 6e 67 2d 66 69 6c 65 20 28 63 6f staging-file (co
7df0: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 2e nc *toppath* "/.
7e00: 6d 65 67 61 74 65 73 74 2e 64 62 22 29 29 0a 09 megatest.db"))..
7e10: 20 28 6d 74 64 62 66 69 6c 65 20 20 20 20 20 28 (mtdbfile (
7e20: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
7e30: 2f 6d 65 67 61 74 65 73 74 2e 64 62 22 29 29 0a /megatest.db")).
7e40: 09 20 28 6c 6f 63 6b 66 69 6c 65 20 20 20 20 20 . (lockfile
7e50: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 73 79 6e 63 (common:get-sync
7e60: 2d 6c 6f 63 6b 2d 66 69 6c 65 70 61 74 68 29 29 -lock-filepath))
7e70: 0a 20 20 20 20 20 20 20 20 20 28 73 79 6e 63 2d . (sync-
7e80: 63 6d 64 2d 63 6f 72 65 20 20 20 20 20 28 63 6f cmd-core (co
7e90: 6e 63 20 73 71 6c 69 74 65 2d 65 78 65 22 20 22 nc sqlite-exe" "
7ea0: 20 74 6d 70 2d 64 62 20 22 20 2e 64 75 6d 70 20 tmp-db " .dump
7eb0: 7c 20 22 73 71 6c 69 74 65 2d 65 78 65 22 20 22 | "sqlite-exe" "
7ec0: 20 73 74 61 67 69 6e 67 2d 66 69 6c 65 20 22 26 staging-file "&
7ed0: 3e 22 73 79 6e 63 2d 6c 6f 67 29 29 0a 20 20 20 >"sync-log)).
7ee0: 20 20 20 20 20 20 28 73 79 6e 63 2d 63 6d 64 20 (sync-cmd
7ef0: 20 20 20 20 28 69 66 20 66 6f 72 6b 2d 74 6f 2d (if fork-to-
7f00: 62 61 63 6b 67 72 6f 75 6e 64 20 0a 20 20 20 20 background .
7f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f20: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 2f 75 (conc "/u
7f30: 73 72 2f 62 69 6e 2f 65 6e 76 20 4e 42 46 41 4b sr/bin/env NBFAK
7f40: 45 5f 4c 4f 47 3d 22 2a 74 6f 70 70 61 74 68 2a E_LOG="*toppath*
7f50: 22 2f 6c 6f 67 73 2f 6c 61 73 74 2d 73 65 72 76 "/logs/last-serv
7f60: 65 72 2d 73 79 6e 63 2d 22 28 63 75 72 72 65 6e er-sync-"(curren
7f70: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 2e 6c t-process-id)".l
7f80: 6f 67 20 6e 62 66 61 6b 65 20 5c 22 22 73 79 6e og nbfake \""syn
7f90: 63 2d 63 6d 64 2d 63 6f 72 65 22 20 26 26 20 2f c-cmd-core" && /
7fa0: 62 69 6e 2f 6d 76 20 2d 66 20 22 20 73 74 61 67 bin/mv -f " stag
7fb0: 69 6e 67 2d 66 69 6c 65 20 22 20 22 20 6d 74 64 ing-file " " mtd
7fc0: 62 66 69 6c 65 22 20 5c 22 22 29 0a 20 20 20 20 bfile" \"").
7fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fe0: 20 20 20 20 20 20 20 73 79 6e 63 2d 63 6d 64 2d sync-cmd-
7ff0: 63 6f 72 65 29 29 0a 20 20 20 20 20 20 20 20 20 core)).
8000: 28 64 65 66 61 75 6c 74 2d 6d 69 6e 2d 69 6e 74 (default-min-int
8010: 65 72 73 79 6e 63 2d 64 65 6c 61 79 20 32 29 0a ersync-delay 2).
8020: 09 20 28 6d 69 6e 2d 69 6e 74 65 72 73 79 6e 63 . (min-intersync
8030: 2d 64 65 6c 61 79 20 28 63 6f 6e 66 69 67 66 3a -delay (configf:
8040: 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 65 72 20 2a 63 lookup-number *c
8050: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 onfigdat* "serve
8060: 72 22 20 22 6d 69 6e 69 6d 75 6d 2d 69 6e 74 65 r" "minimum-inte
8070: 72 73 79 6e 63 2d 64 65 6c 61 79 22 20 64 65 66 rsync-delay" def
8080: 61 75 6c 74 3a 20 64 65 66 61 75 6c 74 2d 6d 69 ault: default-mi
8090: 6e 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 n-intersync-dela
80a0: 79 29 29 0a 20 20 20 20 20 20 20 20 20 28 64 65 y)). (de
80b0: 66 61 75 6c 74 2d 64 75 74 79 2d 63 79 63 6c 65 fault-duty-cycle
80c0: 20 30 2e 31 29 0a 20 20 20 20 20 20 20 20 20 28 0.1). (
80d0: 64 75 74 79 2d 63 79 63 6c 65 20 20 20 28 63 6f duty-cycle (co
80e0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d nfigf:lookup-num
80f0: 62 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 ber *configdat*
8100: 22 73 65 72 76 65 72 22 20 22 73 79 6e 63 2d 64 "server" "sync-d
8110: 75 74 79 2d 63 79 63 6c 65 22 20 64 65 66 61 75 uty-cycle" defau
8120: 6c 74 3a 20 64 65 66 61 75 6c 74 2d 64 75 74 79 lt: default-duty
8130: 2d 63 79 63 6c 65 29 29 0a 20 20 20 20 20 20 20 -cycle)).
8140: 20 20 28 6c 61 73 74 2d 73 79 6e 63 2d 73 65 63 (last-sync-sec
8150: 6f 6e 64 73 20 31 30 29 20 3b 3b 20 77 65 20 77 onds 10) ;; we w
8160: 69 6c 6c 20 61 64 6a 75 73 74 20 74 68 69 73 20 ill adjust this
8170: 74 6f 20 61 20 6d 65 61 73 75 72 65 6d 65 6e 74 to a measurement
8180: 20 61 6e 64 20 64 65 6c 61 79 20 6c 61 73 74 2d and delay last-
8190: 73 79 6e 63 2d 73 65 63 6f 6e 64 73 20 2a 20 28 sync-seconds * (
81a0: 31 20 2d 20 64 75 74 79 2d 63 79 63 6c 65 29 0a 1 - duty-cycle).
81b0: 20 20 20 20 20 20 20 20 20 28 63 61 6c 63 75 6c (calcul
81c0: 61 74 65 2d 6f 66 66 2d 74 69 6d 65 20 28 6c 61 ate-off-time (la
81d0: 6d 62 64 61 20 28 77 6f 72 6b 2d 64 75 72 61 74 mbda (work-durat
81e0: 69 6f 6e 20 64 75 74 79 2d 63 79 63 6c 65 29 0a ion duty-cycle).
81f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8210: 20 20 28 2a 20 28 2f 20 28 2d 20 31 20 64 75 74 (* (/ (- 1 dut
8220: 79 2d 63 79 63 6c 65 29 20 64 75 74 79 2d 63 79 y-cycle) duty-cy
8230: 63 6c 65 29 20 6c 61 73 74 2d 73 79 6e 63 2d 73 cle) last-sync-s
8240: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 econds))).
8250: 20 20 20 28 6f 66 66 2d 74 69 6d 65 20 6d 69 6e (off-time min
8260: 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 -intersync-delay
8270: 29 20 3b 3b 20 61 64 6a 75 73 74 65 64 20 69 6e ) ;; adjusted in
8280: 20 63 6c 6f 73 75 72 65 20 62 65 6c 6f 77 2e 0a closure below..
8290: 20 20 20 20 20 20 20 20 20 28 64 6f 2d 61 2d 73 (do-a-s
82a0: 79 6e 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c ync. (l
82b0: 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 ambda ().
82c0: 20 20 20 20 20 28 42 42 3e 20 22 53 74 61 72 74 (BB> "Start
82d0: 20 64 6f 2d 61 2d 73 79 6e 63 20 77 69 74 68 20 do-a-sync with
82e0: 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 6f 75 fork-to-backgrou
82f0: 6e 64 3d 22 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b nd="fork-to-back
8300: 67 72 6f 75 6e 64 22 20 70 65 72 73 69 73 74 2d ground" persist-
8310: 75 6e 74 69 6c 2d 73 79 6e 63 3d 22 70 65 72 73 until-sync="pers
8320: 69 73 74 2d 75 6e 74 69 6c 2d 73 79 6e 63 29 0a ist-until-sync).
8330: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
8340: 2a 20 28 28 66 69 6e 61 6c 72 65 73 0a 20 20 20 * ((finalres.
8350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8360: 20 28 6c 65 74 20 72 65 74 72 79 2d 6c 6f 6f 70 (let retry-loop
8370: 20 28 28 6e 75 6d 2d 74 72 69 65 73 20 30 29 29 ((num-tries 0))
8380: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8390: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 63 (if (c
83a0: 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c ommon:simple-fil
83b0: 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 e-lock lockfile)
83c0: 0a 09 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
83d0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
83e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
8400: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
8410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8420: 20 20 20 28 28 6e 6f 74 20 28 6f 72 20 66 6f 72 ((not (or for
8430: 6b 2d 74 6f 2d 62 61 63 6b 67 72 6f 75 6e 64 20 k-to-background
8440: 70 65 72 73 69 73 74 2d 75 6e 74 69 6c 2d 73 79 persist-until-sy
8450: 6e 63 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 nc)).
8460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8470: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8480: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
8490: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 73 g-port* "INFO: s
84a0: 79 6e 63 65 72 20 74 68 72 65 61 64 20 73 6c 65 yncer thread sle
84b0: 65 70 69 6e 67 20 66 6f 72 20 6d 61 78 20 6f 66 eping for max of
84c0: 20 28 73 65 72 76 65 72 2e 6d 69 6e 69 6d 75 6d (server.minimum
84d0: 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 -intersync-delay
84e0: 3d 22 6d 69 6e 2d 69 6e 74 65 72 73 79 6e 63 2d ="min-intersync-
84f0: 64 65 6c 61 79 0a 20 20 20 20 20 20 20 20 20 20 delay.
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 20 20 20 20 20 20 20 20
8520: 20 20 20 20 22 20 2c 20 6f 66 66 2d 74 69 6d 65 " , off-time
8530: 3d 22 6f 66 66 2d 74 69 6d 65 22 20 73 65 63 6f ="off-time" seco
8540: 6e 64 73 20 5d 22 29 0a 20 20 20 20 20 20 20 20 nds ]").
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 28 74 68 72 65 61 64 (thread
8570: 2d 73 6c 65 65 70 21 20 28 6d 61 78 20 6f 66 66 -sleep! (max off
8580: 2d 74 69 6d 65 20 6d 69 6e 2d 69 6e 74 65 72 73 -time min-inters
8590: 79 6e 63 2d 64 65 6c 61 79 29 29 29 0a 20 20 20 ync-delay))).
85a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
85c0: 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 se.
85d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85e0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
85f0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
8600: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 73 79 6e port* "INFO: syn
8610: 63 65 72 20 74 68 72 65 61 64 20 4e 4f 54 20 73 cer thread NOT s
8620: 6c 65 65 70 69 6e 67 20 3b 20 6d 61 79 62 65 20 leeping ; maybe
8630: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2e 2e 2e 22 time-to-exit..."
8640: 29 29 29 0a 0a 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 20 20
8660: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 63 6f (if (not (co
8670: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
8680: 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 nfigdat* "server
8690: 22 20 22 64 69 73 61 62 6c 65 2d 64 62 2d 73 6e " "disable-db-sn
86a0: 61 70 73 68 6f 74 22 29 29 0a 20 20 20 20 20 20 apshot")).
86b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
86d0: 6d 6d 6f 6e 3a 73 6e 61 70 73 68 6f 74 2d 66 69 mmon:snapshot-fi
86e0: 6c 65 20 6d 74 64 62 66 69 6c 65 20 73 75 62 64 le mtdbfile subd
86f0: 69 72 3a 20 22 2e 64 62 2d 73 6e 61 70 73 68 6f ir: ".db-snapsho
8700: 74 22 29 29 0a 09 09 20 20 20 20 20 20 20 20 20 t"))...
8710: 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 (delete-fi
8720: 6c 65 2a 20 73 74 61 67 69 6e 67 2d 66 69 6c 65 le* staging-file
8730: 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 20 20 )...
8740: 20 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 (let* ((start
8750: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d -time (current-m
8760: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 20 20 illiseconds)).
8770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8790: 20 20 20 20 28 72 65 73 20 28 73 79 73 74 65 6d (res (system
87a0: 20 73 79 6e 63 2d 63 6d 64 29 29 0a 20 20 20 20 sync-cmd)).
87b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87d0: 20 20 28 64 62 62 61 63 6b 75 70 66 69 6c 65 20 (dbbackupfile
87e0: 28 63 6f 6e 63 20 6d 74 64 62 66 69 6c 65 20 22 (conc mtdbfile "
87f0: 2e 62 61 63 6b 75 70 22 29 29 0a 20 20 20 20 20 .backup")).
8800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8820: 20 28 72 65 73 32 20 0a 20 20 20 20 20 20 20 20 (res2 .
8830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8850: 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 cond.
8860: 20 20 20 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 28 28 65 ((e
8880: 71 3f 20 30 20 72 65 73 20 29 0a 20 20 20 20 20 q? 0 res ).
8890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88b0: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
88c0: 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 ptions.
88d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88f0: 20 20 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 exn.
8900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8920: 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 #f.
8930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8950: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
8960: 20 64 62 62 61 63 6b 75 70 66 69 6c 65 29 0a 09 dbbackupfile)..
8970: 09 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8980: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 6c (del
8990: 65 74 65 2d 66 69 6c 65 2a 20 64 62 62 61 63 6b ete-file* dbback
89a0: 75 70 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 upfile).
89b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89d0: 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
89e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
8a00: 28 65 71 3f 20 30 20 28 66 69 6c 65 2d 73 69 7a (eq? 0 (file-siz
8a10: 65 20 73 79 6e 63 2d 6c 6f 67 29 29 0a 20 20 20 e sync-log)).
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 20 20 20 20 20 20 28 64 65 6c 65 74 (delet
8a50: 65 2d 66 69 6c 65 2a 20 73 79 6e 63 2d 6c 6f 67 e-file* sync-log
8a60: 29 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 20 ))...
8a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
8a80: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 2f 62 69 ystem (conc "/bi
8a90: 6e 2f 6d 76 20 22 20 73 74 61 67 69 6e 67 2d 66 n/mv " staging-f
8aa0: 69 6c 65 20 22 20 22 20 6d 74 64 62 66 69 6c 65 ile " " mtdbfile
8ab0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ad0: 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 .
8ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b00: 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 (set! last
8b10: 2d 73 79 6e 63 2d 73 65 63 6f 6e 64 73 20 28 2f -sync-seconds (/
8b20: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c (- (current-mil
8b30: 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 liseconds) start
8b40: 2d 74 69 6d 65 29 20 31 30 30 30 29 29 0a 20 20 -time) 1000)).
8b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b70: 20 20 20 20 20 20 20 28 73 65 74 21 20 6f 66 66 (set! off
8b80: 2d 74 69 6d 65 20 28 63 61 6c 63 75 6c 61 74 65 -time (calculate
8b90: 2d 6f 66 66 2d 74 69 6d 65 0a 20 20 20 20 20 20 -off-time.
8ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 20 20 6c 61 73 74 2d 73 79 6e 63 2d 73 65 63 last-sync-sec
8be0: 6f 6e 64 73 0a 20 20 20 20 20 20 20 20 20 20 20 onds.
8bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
8c20: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 ond.
8c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c40: 20 20 20 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 28 28 ((
8c60: 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 64 75 74 and (number? dut
8c70: 79 2d 63 79 63 6c 65 29 20 28 3e 20 64 75 74 79 y-cycle) (> duty
8c80: 2d 63 79 63 6c 65 20 30 29 20 28 3c 20 64 75 74 -cycle 0) (< dut
8c90: 79 2d 63 79 63 6c 65 20 31 29 29 0a 20 20 20 20 y-cycle 1)).
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 20 20 20 20 20 20 20 20
8cd0: 20 20 20 20 20 20 20 64 75 74 79 2d 63 79 63 6c duty-cycl
8ce0: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
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 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
8d20: 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 se.
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 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
8d60: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
8d70: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
8d80: 22 57 41 52 4e 49 4e 47 3a 20 5b 22 28 63 6f 6d "WARNING: ["(com
8d90: 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 22 mon:human-time)"
8da0: 5d 20 73 65 72 76 65 72 2e 73 79 6e 63 2d 64 75 ] server.sync-du
8db0: 74 79 2d 63 79 63 6c 65 20 69 73 20 69 6e 76 61 ty-cycle is inva
8dc0: 6c 69 64 2e 20 20 53 68 6f 75 6c 64 20 62 65 20 lid. Should be
8dd0: 61 20 6e 75 6d 62 65 72 20 62 65 74 77 65 65 6e a number between
8de0: 20 30 20 61 6e 64 20 31 2c 20 62 75 74 20 22 64 0 and 1, but "d
8df0: 75 74 79 2d 63 79 63 6c 65 22 20 77 61 73 20 73 uty-cycle" was s
8e00: 70 65 63 69 66 69 65 64 2e 20 20 55 73 69 6e 67 pecified. Using
8e10: 20 64 65 66 61 75 6c 74 20 76 61 6c 75 65 3a 20 default value:
8e20: 22 64 65 66 61 75 6c 74 2d 64 75 74 79 2d 63 79 "default-duty-cy
8e30: 63 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 cle).
8e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e70: 64 65 66 61 75 6c 74 2d 64 75 74 79 2d 63 79 63 default-duty-cyc
8e80: 6c 65 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 le)))).
8e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8eb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ed0: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
8ee0: 3a 70 72 69 6e 74 20 31 20 2a 64 65 66 61 75 6c :print 1 *defaul
8ef0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
8f00: 4f 3a 20 5b 22 28 63 6f 6d 6d 6f 6e 3a 68 75 6d O: ["(common:hum
8f10: 61 6e 2d 74 69 6d 65 29 22 5d 20 70 69 64 3d 22 an-time)"] pid="
8f20: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
8f30: 2d 69 64 29 22 20 53 59 4e 43 20 74 6f 6f 6b 20 -id)" SYNC took
8f40: 22 6c 61 73 74 2d 73 79 6e 63 2d 73 65 63 6f 6e "last-sync-secon
8f50: 64 73 22 20 73 65 63 22 29 0a 20 20 20 20 20 20 ds" sec").
8f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f80: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
8f90: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
8fa0: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 5b 22 28 63 ort* "INFO: ["(c
8fb0: 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 ommon:human-time
8fc0: 29 22 5d 20 70 69 64 3d 22 28 63 75 72 72 65 6e )"] pid="(curren
8fd0: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 53 t-process-id)" S
8fe0: 59 4e 43 20 74 6f 6f 6b 20 22 6c 61 73 74 2d 73 YNC took "last-s
8ff0: 79 6e 63 2d 73 65 63 6f 6e 64 73 22 20 73 65 63 ync-seconds" sec
9000: 20 3b 20 77 69 74 68 20 64 75 74 79 2d 63 79 63 ; with duty-cyc
9010: 6c 65 20 6f 66 20 22 64 75 74 79 2d 63 79 63 6c le of "duty-cycl
9020: 65 22 20 6f 66 66 20 74 69 6d 65 20 69 73 20 6e e" off time is n
9030: 6f 77 20 22 6f 66 66 2d 74 69 6d 65 29 0a 20 20 ow "off-time).
9040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 27 73 79 6e 63 2d 63 6f 6d 'sync-com
9070: 70 6c 65 74 65 64 29 29 0a 20 20 20 20 20 20 20 pleted)).
9080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90a0: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 (else.
90b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90d0: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 2f (system (conc "/
90e0: 62 69 6e 2f 63 70 20 22 73 79 6e 63 2d 6c 6f 67 bin/cp "sync-log
90f0: 22 20 22 73 79 6e 63 2d 6c 6f 67 22 2e 66 61 69 " "sync-log".fai
9100: 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 l")).
9110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
9130: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
9140: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
9150: 22 45 52 52 4f 52 3a 20 5b 22 28 63 6f 6d 6d 6f "ERROR: ["(commo
9160: 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 22 5d 20 n:human-time)"]
9170: 53 79 6e 63 20 66 61 69 6c 65 64 2e 20 53 65 65 Sync failed. See
9180: 20 6c 6f 67 20 61 74 20 22 73 79 6e 63 2d 6c 6f log at "sync-lo
9190: 67 22 2e 66 61 69 6c 22 29 0a 20 20 20 20 20 20 g".fail").
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 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
91d0: 73 74 73 3f 20 28 63 6f 6e 63 20 6d 74 64 62 66 sts? (conc mtdbf
91e0: 69 6c 65 20 22 2e 62 61 63 6b 75 70 22 29 29 0a ile ".backup")).
91f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 73 79 (sy
9220: 73 74 65 6d 20 28 63 6f 6e 63 20 22 2f 62 69 6e stem (conc "/bin
9230: 2f 63 70 20 22 6d 74 64 62 66 69 6c 65 20 22 2e /cp "mtdbfile ".
9240: 62 61 63 6b 75 70 20 22 20 6d 74 64 62 66 69 6c backup " mtdbfil
9250: 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e))).
9260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 #f
9280: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
9290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92a0: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 (common:si
92b0: 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 mple-file-releas
92c0: 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 e-lock lockfile)
92d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
92e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92f0: 20 20 28 42 42 3e 20 22 72 65 6c 65 61 73 65 64 (BB> "released
9300: 20 6c 6f 63 6b 66 69 6c 65 3a 20 22 20 6c 6f 63 lockfile: " loc
9310: 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 kfile).
9320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9330: 20 20 20 20 20 20 20 20 28 77 68 65 6e 20 28 63 (when (c
9340: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
9350: 73 3f 20 6c 6f 63 6b 66 69 6c 65 29 0a 20 20 20 s? lockfile).
9360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9380: 28 42 42 3e 20 22 44 49 44 20 4e 4f 54 20 41 43 (BB> "DID NOT AC
9390: 54 55 41 4c 4c 59 20 52 45 4c 45 41 53 45 20 4c TUALLY RELEASE L
93a0: 4f 43 4b 46 49 4c 45 22 29 29 0a 20 20 20 20 20 OCKFILE")).
93b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93c0: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 32 res2
93d0: 29 20 3b 3b 20 65 6e 64 20 6c 65 74 0a 20 20 20 ) ;; end let.
93e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93f0: 20 20 20 20 20 20 20 20 20 20 20 20 29 3b 3b 20 );;
9400: 65 6e 64 20 62 65 67 69 6e 0a 20 20 20 20 20 20 end begin.
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 3b 3b 20 65 6c 73 65 0a 20 ;; else.
9430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9440: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
9450: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
9460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9470: 28 70 65 72 73 69 73 74 2d 75 6e 74 69 6c 2d 73 (persist-until-s
9480: 79 6e 63 0a 20 20 20 20 20 20 20 20 20 20 20 20 ync.
9490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
94a0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
94b0: 21 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 ! 1).
94c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
94d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
94e0: 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
94f0: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 5b 22 28 port* "INFO: ["(
9500: 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d common:human-tim
9510: 65 29 22 5d 20 70 69 64 3d 22 28 63 75 72 72 65 e)"] pid="(curre
9520: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 nt-process-id)"
9530: 6f 74 68 65 72 20 53 59 4e 43 20 69 6e 20 70 72 other SYNC in pr
9540: 6f 67 72 65 73 73 3b 20 77 65 27 72 65 20 69 6e ogress; we're in
9550: 20 61 20 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 a fork-to-backg
9560: 72 6f 75 6e 64 20 73 6f 20 77 65 20 6e 65 65 64 round so we need
9570: 20 74 6f 20 73 75 63 63 65 65 64 2e 20 20 4c 65 to succeed. Le
9580: 74 27 73 20 77 61 69 74 20 61 20 6a 69 66 66 79 t's wait a jiffy
9590: 20 61 6e 64 20 61 6e 64 20 74 72 79 20 61 67 61 and and try aga
95a0: 69 6e 2e 20 6e 75 6d 2d 74 72 69 65 73 3d 22 6e in. num-tries="n
95b0: 75 6d 2d 74 72 69 65 73 22 20 28 77 61 69 74 69 um-tries" (waiti
95c0: 6e 67 20 66 6f 72 20 6c 6f 63 6b 66 69 6c 65 3d ng for lockfile=
95d0: 22 6c 6f 63 6b 66 69 6c 65 22 20 74 6f 20 64 69 "lockfile" to di
95e0: 73 61 70 70 65 61 72 29 22 29 0a 20 20 20 20 20 sappear)").
95f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9600: 20 20 20 20 20 20 20 20 20 20 28 72 65 74 72 79 (retry
9610: 2d 6c 6f 6f 70 20 28 61 64 64 31 20 6e 75 6d 2d -loop (add1 num-
9620: 74 72 69 65 73 29 29 29 0a 20 20 20 20 20 20 20 tries))).
9630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9640: 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 (else.
9650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9660: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 68 72 (thr
9670: 65 61 64 2d 73 6c 65 65 70 21 20 28 6d 61 78 20 ead-sleep! (max
9680: 6f 66 66 2d 74 69 6d 65 20 28 2b 20 6c 61 73 74 off-time (+ last
9690: 2d 73 79 6e 63 2d 73 65 63 6f 6e 64 73 20 6d 69 -sync-seconds mi
96a0: 6e 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 n-intersync-dela
96b0: 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 y))).
96c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
96e0: 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
96f0: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 5b 22 28 port* "INFO: ["(
9700: 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d common:human-tim
9710: 65 29 22 5d 20 70 69 64 3d 22 28 63 75 72 72 65 e)"] pid="(curre
9720: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 nt-process-id)"
9730: 6f 74 68 65 72 20 53 59 4e 43 20 69 6e 20 70 72 other SYNC in pr
9740: 6f 67 72 65 73 73 3b 20 6e 6f 74 20 73 79 6e 63 ogress; not sync
9750: 69 6e 67 2e 22 29 0a 20 20 20 20 20 20 20 20 20 ing.").
9760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9770: 20 20 20 20 20 20 27 70 61 72 61 6c 6c 65 6c 2d 'parallel-
9780: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
9790: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
97a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97b0: 29 20 3b 3b 20 65 6e 64 20 69 66 20 67 6f 74 20 ) ;; end if got
97c0: 6c 6f 63 6b 66 69 6c 65 0a 20 20 20 20 20 20 20 lockfile.
97d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97e0: 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ).
97f0: 20 20 20 20 20 20 20 20 29 29 0a 20 20 20 20 20 )).
9800: 20 20 20 20 20 20 20 20 20 28 42 42 3e 20 22 45 (BB> "E
9810: 6e 64 20 64 6f 2d 61 2d 73 79 6e 63 20 77 69 74 nd do-a-sync wit
9820: 68 20 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 h fork-to-backgr
9830: 6f 75 6e 64 3d 22 66 6f 72 6b 2d 74 6f 2d 62 61 ound="fork-to-ba
9840: 63 6b 67 72 6f 75 6e 64 22 20 70 65 72 73 69 73 ckground" persis
9850: 74 2d 75 6e 74 69 6c 2d 73 79 6e 63 3d 22 70 65 t-until-sync="pe
9860: 72 73 69 73 74 2d 75 6e 74 69 6c 2d 73 79 6e 63 rsist-until-sync
9870: 22 20 61 6e 64 20 72 65 73 75 6c 74 3d 22 66 69 " and result="fi
9880: 6e 61 6c 72 65 73 29 0a 20 20 20 20 20 20 20 20 nalres).
9890: 20 20 20 20 20 20 66 69 6e 61 6c 72 65 73 29 0a finalres).
98a0: 20 20 20 20 20 20 20 20 20 20 20 20 29 20 3b 3b ) ;;
98b0: 20 65 6e 64 20 6c 61 6d 62 64 61 0a 20 20 20 20 end lambda.
98c0: 20 20 20 20 20 20 29 29 0a 20 20 20 20 64 6f 2d )). do-
98d0: 61 2d 73 79 6e 63 29 29 0a 0a a-sync))..