Artifact
2869b015cba091970aaa0bf0f5eebf117c38fcc1:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 37 2c 20 4d 61 74 74 68 65 77 06-2017, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 28 72 65 71 75 PURPOSE...(requ
0150: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
0160: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
0170: 63 70 20 73 31 31 6e 29 0a 0a 28 75 73 65 20 73 cp s11n)..(use s
0180: 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 rfi-1 posix rege
0190: 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 x regex-case srf
01a0: 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d 64 i-69 hostinfo md
01b0: 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 5 message-digest
01c0: 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 directory-utils
01d0: 20 70 6f 73 69 78 2d 65 78 74 72 61 73 20 6d 61 posix-extras ma
01e0: 74 63 68 61 62 6c 65 0a 20 20 20 20 20 29 0a 0a tchable. )..
01f0: 28 75 73 65 20 73 70 69 66 66 79 20 75 72 69 2d (use spiffy uri-
0200: 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 common intarweb
0210: 68 74 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 http-client spif
0220: 66 79 2d 72 65 71 75 65 73 74 2d 76 61 72 73 29 fy-request-vars)
0230: 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 ..(declare (unit
0240: 20 73 65 72 76 65 72 29 29 0a 0a 28 64 65 63 6c server))..(decl
0250: 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e are (uses common
0260: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0270: 73 20 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 s db)).(declare
0280: 28 75 73 65 73 20 74 61 73 6b 73 29 29 20 3b 3b (uses tasks)) ;;
0290: 20 74 61 73 6b 73 20 61 72 65 20 77 68 65 72 65 tasks are where
02a0: 20 73 74 75 66 66 20 69 73 20 6d 61 69 6e 74 61 stuff is mainta
02b0: 69 6e 65 64 20 61 62 6f 75 74 20 77 68 61 74 20 ined about what
02c0: 69 73 20 72 75 6e 6e 69 6e 67 2e 0a 3b 3b 20 28 is running..;; (
02d0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 79 declare (uses sy
02e0: 6e 63 68 61 73 68 29 29 0a 28 64 65 63 6c 61 72 nchash)).(declar
02f0: 65 20 28 75 73 65 73 20 68 74 74 70 2d 74 72 61 e (uses http-tra
0300: 6e 73 70 6f 72 74 29 29 0a 28 64 65 63 6c 61 72 nsport)).(declar
0310: 65 20 28 75 73 65 73 20 6c 61 75 6e 63 68 29 29 e (uses launch))
0320: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0330: 64 61 65 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c 75 daemon))..(inclu
0340: 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 de "common_recor
0350: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0360: 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 e "db_records.sc
0370: 6d 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 m")..(define (se
0380: 72 76 65 72 3a 6d 61 6b 65 2d 73 65 72 76 65 72 rver:make-server
0390: 2d 75 72 6c 20 68 6f 73 74 70 6f 72 74 29 0a 20 -url hostport).
03a0: 20 28 69 66 20 28 6e 6f 74 20 68 6f 73 74 70 6f (if (not hostpo
03b0: 72 74 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 rt). #f.
03c0: 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f (conc "http:/
03d0: 2f 22 20 28 63 61 72 20 68 6f 73 74 70 6f 72 74 /" (car hostport
03e0: 29 20 22 3a 22 20 28 63 61 64 72 20 68 6f 73 74 ) ":" (cadr host
03f0: 70 6f 72 74 29 29 29 29 0a 0a 28 64 65 66 69 6e port))))..(defin
0400: 65 20 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d e *server-loop-
0410: 68 65 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 heart-beat* (cur
0420: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 0a rent-seconds))..
0430: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0470: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 50 20 4b 20 ========.;; P K
0480: 54 20 53 20 20 20 53 20 54 20 55 20 46 20 46 20 T S S T U F F
0490: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 3f 3f =========..;; ??
04e0: 3f 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ?..;;===========
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 ===========.;; S
0530: 20 45 20 52 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d E R V E R.;;===
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0580: 3d 3d 3d 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 ===..;; Call thi
0590: 73 20 74 6f 20 73 74 61 72 74 20 74 68 65 20 61 s to start the a
05a0: 63 74 75 61 6c 20 73 65 72 76 65 72 0a 3b 3b 0a ctual server.;;.
05b0: 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 .;; all routes t
05c0: 68 6f 75 67 68 20 68 65 72 65 20 65 6e 64 20 69 hough here end i
05d0: 6e 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b n exit ....;;.;;
05e0: 20 73 74 61 72 74 5f 73 65 72 76 65 72 0a 3b 3b start_server.;;
05f0: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
0600: 3a 6c 61 75 6e 63 68 20 72 75 6e 2d 69 64 20 74 :launch run-id t
0610: 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 29 0a 20 ransport-type).
0620: 20 28 63 61 73 65 20 74 72 61 6e 73 70 6f 72 74 (case transport
0630: 2d 74 79 70 65 0a 20 20 20 20 28 28 68 74 74 70 -type. ((http
0640: 29 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 )(http-transport
0650: 3a 6c 61 75 6e 63 68 29 29 0a 20 20 20 20 3b 3b :launch)). ;;
0660: 28 28 6e 6d 73 67 29 28 6e 6d 73 67 2d 74 72 61 ((nmsg)(nmsg-tra
0670: 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 72 75 nsport:launch ru
0680: 6e 2d 69 64 29 29 0a 20 20 20 20 28 28 72 70 63 n-id)). ((rpc
0690: 29 20 20 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 ) (rpc-transpor
06a0: 74 3a 6c 61 75 6e 63 68 20 72 75 6e 2d 69 64 29 t:launch run-id)
06b0: 29 0a 20 20 20 20 28 65 6c 73 65 20 28 64 65 62 ). (else (deb
06c0: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
06d0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
06e0: 72 74 2a 20 22 75 6e 6b 6e 6f 77 6e 20 73 65 72 rt* "unknown ser
06f0: 76 65 72 20 74 79 70 65 20 22 20 74 72 61 6e 73 ver type " trans
0700: 70 6f 72 74 2d 74 79 70 65 29 29 29 29 0a 0a 3b port-type))))..;
0710: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
0720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0750: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 =======.;; S E R
0760: 20 56 20 45 20 52 20 20 20 55 20 54 20 49 20 4c V E R U T I L
0770: 20 49 20 54 20 49 20 45 20 53 20 0a 3b 3b 3d 3d I T I E S .;;==
0780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07c0: 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 20 74 68 65 ====..;; Get the
07d0: 20 74 72 61 6e 73 70 6f 72 74 0a 28 64 65 66 69 transport.(defi
07e0: 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 74 ne (server:get-t
07f0: 72 61 6e 73 70 6f 72 74 29 0a 20 20 28 69 66 20 ransport). (if
0800: 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a *transport-type*
0810: 0a 20 20 20 20 20 20 2a 74 72 61 6e 73 70 6f 72 . *transpor
0820: 74 2d 74 79 70 65 2a 0a 20 20 20 20 20 20 28 6c t-type*. (l
0830: 65 74 20 28 28 74 74 79 70 65 20 28 73 74 72 69 et ((ttype (stri
0840: 6e 67 2d 3e 73 79 6d 62 6f 6c 0a 09 09 20 20 20 ng->symbol...
0850: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
0860: 72 67 20 22 2d 74 72 61 6e 73 70 6f 72 74 22 29 rg "-transport")
0870: 0a 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ....(configf:loo
0880: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
0890: 22 73 65 72 76 65 72 22 20 22 74 72 61 6e 73 70 "server" "transp
08a0: 6f 72 74 22 29 0a 09 09 09 22 72 70 63 22 29 29 ort")...."rpc"))
08b0: 29 29 0a 09 28 73 65 74 21 20 2a 74 72 61 6e 73 ))..(set! *trans
08c0: 70 6f 72 74 2d 74 79 70 65 2a 20 74 74 79 70 65 port-type* ttype
08d0: 29 0a 09 74 74 79 70 65 29 29 29 0a 09 20 20 20 )..ttype)))..
08e0: 20 0a 3b 3b 20 47 65 6e 65 72 61 74 65 20 61 20 .;; Generate a
08f0: 75 6e 69 71 75 65 20 73 69 67 6e 61 74 75 72 65 unique signature
0900: 20 66 6f 72 20 74 68 69 73 20 73 65 72 76 65 72 for this server
0910: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
0920: 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 :mk-signature).
0930: 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 (message-digest
0940: 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 -string (md5-pri
0950: 6d 69 74 69 76 65 29 20 0a 09 09 09 20 28 77 69 mitive) .... (wi
0960: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 th-output-to-str
0970: 69 6e 67 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 ing.... (lambd
0980: 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 77 72 a ().... (wr
0990: 69 74 65 20 28 6c 69 73 74 20 28 63 75 72 72 65 ite (list (curre
09a0: 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 09 nt-directory)...
09b0: 09 09 09 20 20 28 61 72 67 76 29 29 29 29 29 29 ... (argv))))))
09c0: 29 0a 0a 3b 3b 20 57 68 65 6e 20 75 73 69 6e 67 )..;; When using
09d0: 20 7a 6d 71 20 74 68 69 73 20 77 6f 75 6c 64 20 zmq this would
09e0: 73 65 6e 64 20 74 68 65 20 6d 65 73 73 61 67 65 send the message
09f0: 20 62 61 63 6b 20 28 74 77 6f 20 73 74 65 70 20 back (two step
0a00: 70 72 6f 63 65 73 73 29 0a 3b 3b 20 77 69 74 68 process).;; with
0a10: 20 73 70 69 66 66 79 20 6f 72 20 72 70 63 20 74 spiffy or rpc t
0a20: 68 69 73 20 73 69 6d 70 6c 79 20 72 65 74 75 72 his simply retur
0a30: 6e 73 20 74 68 65 20 72 65 74 75 72 6e 20 64 61 ns the return da
0a40: 74 61 20 74 6f 20 62 65 20 72 65 74 75 72 6e 65 ta to be returne
0a50: 64 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 d.;; .(define (s
0a60: 65 72 76 65 72 3a 72 65 70 6c 79 20 72 65 74 75 erver:reply retu
0a70: 72 6e 2d 61 64 64 72 20 71 75 65 72 79 2d 73 69 rn-addr query-si
0a80: 67 20 73 75 63 63 65 73 73 2f 66 61 69 6c 20 72 g success/fail r
0a90: 65 73 75 6c 74 29 0a 20 20 28 64 65 62 75 67 3a esult). (debug:
0aa0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 2a 64 print-info 11 *d
0ab0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0ac0: 20 22 73 65 72 76 65 72 3a 72 65 70 6c 79 20 72 "server:reply r
0ad0: 65 74 75 72 6e 2d 61 64 64 72 3d 22 20 72 65 74 eturn-addr=" ret
0ae0: 75 72 6e 2d 61 64 64 72 20 22 2c 20 72 65 73 75 urn-addr ", resu
0af0: 6c 74 3d 22 20 72 65 73 75 6c 74 29 0a 20 20 3b lt=" result). ;
0b00: 3b 20 28 73 65 6e 64 2d 6d 65 73 73 61 67 65 20 ; (send-message
0b10: 70 75 62 73 6f 63 6b 20 74 61 72 67 65 74 20 73 pubsock target s
0b20: 65 6e 64 2d 6d 6f 72 65 3a 20 23 74 29 0a 20 20 end-more: #t).
0b30: 3b 3b 20 28 73 65 6e 64 2d 6d 65 73 73 61 67 65 ;; (send-message
0b40: 20 70 75 62 73 6f 63 6b 20 0a 20 20 28 63 61 73 pubsock . (cas
0b50: 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 74 72 e (server:get-tr
0b60: 61 6e 73 70 6f 72 74 29 0a 20 20 20 20 28 28 72 ansport). ((r
0b70: 70 63 29 20 20 28 64 62 3a 6f 62 6a 2d 3e 73 74 pc) (db:obj->st
0b80: 72 69 6e 67 20 28 76 65 63 74 6f 72 20 73 75 63 ring (vector suc
0b90: 63 65 73 73 2f 66 61 69 6c 20 71 75 65 72 79 2d cess/fail query-
0ba0: 73 69 67 20 72 65 73 75 6c 74 29 29 29 0a 20 20 sig result))).
0bb0: 20 20 28 28 68 74 74 70 29 20 28 64 62 3a 6f 62 ((http) (db:ob
0bc0: 6a 2d 3e 73 74 72 69 6e 67 20 28 76 65 63 74 6f j->string (vecto
0bd0: 72 20 73 75 63 63 65 73 73 2f 66 61 69 6c 20 71 r success/fail q
0be0: 75 65 72 79 2d 73 69 67 20 72 65 73 75 6c 74 29 uery-sig result)
0bf0: 29 29 0a 20 20 20 20 28 28 66 73 29 20 20 20 72 )). ((fs) r
0c00: 65 73 75 6c 74 29 0a 20 20 20 20 28 65 6c 73 65 esult). (else
0c10: 20 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
0c20: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
0c30: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
0c40: 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 74 72 61 unrecognised tra
0c50: 6e 73 70 6f 72 74 20 74 79 70 65 3a 20 22 20 2a nsport type: " *
0c60: 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 29 transport-type*)
0c70: 0a 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a . result))).
0c80: 0a 3b 3b 20 47 69 76 65 6e 20 61 20 72 75 6e 20 .;; Given a run
0c90: 69 64 20 73 74 61 72 74 20 61 20 73 65 72 76 65 id start a serve
0ca0: 72 20 70 72 6f 63 65 73 73 20 20 20 20 23 23 23 r process ###
0cb0: 20 4e 4f 54 45 20 23 23 23 20 3e 20 66 69 6c 65 NOTE ### > file
0cc0: 20 32 3e 26 31 20 0a 3b 3b 20 69 66 20 74 68 65 2>&1 .;; if the
0cd0: 20 72 75 6e 2d 69 64 20 69 73 20 7a 65 72 6f 20 run-id is zero
0ce0: 61 6e 64 20 74 68 65 20 74 61 72 67 65 74 2d 68 and the target-h
0cf0: 6f 73 74 20 69 73 20 73 65 74 20 0a 3b 3b 20 74 ost is set .;; t
0d00: 72 79 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 68 ry running on th
0d10: 61 74 20 68 6f 73 74 0a 3b 3b 20 20 20 69 6e 63 at host.;; inc
0d20: 69 64 65 6e 74 61 6c 3a 20 72 6f 74 61 74 65 20 idental: rotate
0d30: 6c 6f 67 73 20 69 6e 20 6c 6f 67 73 2f 20 64 69 logs in logs/ di
0d40: 72 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 20 28 r..;;.(define (
0d50: 73 65 72 76 65 72 3a 72 75 6e 20 61 72 65 61 70 server:run areap
0d60: 61 74 68 29 20 3b 3b 20 61 72 65 61 70 61 74 68 ath) ;; areapath
0d70: 20 69 73 20 2a 74 6f 70 70 61 74 68 2a 20 66 6f is *toppath* fo
0d80: 72 20 61 20 67 69 76 65 6e 20 74 65 73 74 73 75 r a given testsu
0d90: 69 74 65 20 61 72 65 61 0a 20 20 28 6c 65 74 2a ite area. (let*
0da0: 20 28 28 63 75 72 72 2d 68 6f 73 74 20 20 20 28 ((curr-host (
0db0: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a get-host-name)).
0dc0: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 61 74 74 ;; (att
0dd0: 65 6d 70 74 2d 69 6e 2d 70 72 6f 67 72 65 73 73 empt-in-progress
0de0: 20 28 73 65 72 76 65 72 3a 73 74 61 72 74 2d 61 (server:start-a
0df0: 74 74 65 6d 70 74 65 64 3f 20 61 72 65 61 70 61 ttempted? areapa
0e00: 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 3b 3b th)). ;;
0e10: 20 28 64 6f 74 2d 73 65 72 76 65 72 2d 75 72 6c (dot-server-url
0e20: 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 (server:check-i
0e30: 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 61 f-running areapa
0e40: 74 68 29 29 0a 09 20 28 63 75 72 72 2d 69 70 20 th)).. (curr-ip
0e50: 20 20 20 20 28 73 65 72 76 65 72 3a 67 65 74 2d (server:get-
0e60: 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 best-guess-addre
0e70: 73 73 20 63 75 72 72 2d 68 6f 73 74 29 29 0a 09 ss curr-host))..
0e80: 20 28 63 75 72 72 2d 70 69 64 20 20 20 20 28 63 (curr-pid (c
0e90: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
0ea0: 64 29 29 0a 09 20 28 68 6f 6d 65 68 6f 73 74 20 d)).. (homehost
0eb0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 (common:get-h
0ec0: 6f 6d 65 68 6f 73 74 29 29 20 3b 3b 20 63 6f 6e omehost)) ;; con
0ed0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
0ee0: 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 figdat* "server"
0ef0: 20 22 68 6f 6d 65 68 6f 73 74 22 20 29 29 0a 09 "homehost" ))..
0f00: 20 28 74 61 72 67 65 74 2d 68 6f 73 74 20 28 63 (target-host (c
0f10: 61 72 20 68 6f 6d 65 68 6f 73 74 29 29 0a 09 20 ar homehost))..
0f20: 28 74 65 73 74 73 75 69 74 65 20 20 20 28 63 6f (testsuite (co
0f30: 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 mmon:get-testsui
0f40: 74 65 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 te-name)).. (log
0f50: 66 69 6c 65 20 20 20 20 20 28 63 6f 6e 63 20 61 file (conc a
0f60: 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 2f 73 reapath "/logs/s
0f70: 65 72 76 65 72 2e 6c 6f 67 22 29 29 20 3b 3b 20 erver.log")) ;;
0f80: 2d 22 20 63 75 72 72 2d 70 69 64 20 22 2d 22 20 -" curr-pid "-"
0f90: 74 61 72 67 65 74 2d 68 6f 73 74 20 22 2e 6c 6f target-host ".lo
0fa0: 67 22 29 29 0a 09 20 28 63 6d 64 6c 6e 20 28 63 g")).. (cmdln (c
0fb0: 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d onc (common:get-
0fc0: 6d 65 67 61 74 65 73 74 2d 65 78 65 29 0a 09 09 megatest-exe)...
0fd0: 20 20 20 20 20 20 22 20 2d 73 65 72 76 65 72 20 " -server
0fe0: 22 20 28 6f 72 20 74 61 72 67 65 74 2d 68 6f 73 " (or target-hos
0ff0: 74 20 22 2d 22 29 20 28 69 66 20 28 65 71 75 61 t "-") (if (equa
1000: 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b l? (configf:look
1010: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
1020: 73 65 72 76 65 72 22 20 22 64 61 65 6d 6f 6e 69 server" "daemoni
1030: 7a 65 22 29 20 22 79 65 73 22 29 0a 09 09 09 09 ze") "yes").....
1040: 09 09 09 20 20 20 22 20 2d 64 61 65 6d 6f 6e 69 ... " -daemoni
1050: 7a 65 20 22 0a 09 09 09 09 09 09 09 20 20 20 22 ze "........ "
1060: 22 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 22 20 ")... ;; "
1070: 2d 6c 6f 67 20 22 20 6c 6f 67 66 69 6c 65 0a 09 -log " logfile..
1080: 09 20 20 20 20 20 20 22 20 2d 6d 20 74 65 73 74 . " -m test
1090: 73 75 69 74 65 3a 22 20 74 65 73 74 73 75 69 74 suite:" testsuit
10a0: 65 29 29 20 3b 3b 20 28 63 6f 6e 63 20 22 20 3e e)) ;; (conc " >
10b0: 3e 20 22 20 6c 6f 67 66 69 6c 65 20 22 20 32 3e > " logfile " 2>
10c0: 26 31 20 26 22 29 29 29 29 29 0a 09 20 28 6c 6f &1 &"))))).. (lo
10d0: 67 2d 72 6f 74 61 74 65 20 20 28 6d 61 6b 65 2d g-rotate (make-
10e0: 74 68 72 65 61 64 20 63 6f 6d 6d 6f 6e 3a 72 6f thread common:ro
10f0: 74 61 74 65 2d 6c 6f 67 73 20 20 22 73 65 72 76 tate-logs "serv
1100: 65 72 20 72 75 6e 2c 20 72 6f 74 61 74 65 20 6c er run, rotate l
1110: 6f 67 73 20 74 68 72 65 61 64 22 29 29 0a 20 20 ogs thread")).
1120: 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 6c 69 6d (load-lim
1130: 69 74 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f it (configf:loo
1140: 6b 75 70 2d 6e 75 6d 62 65 72 20 2a 63 6f 6e 66 kup-number *conf
1150: 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f 6f 6c 73 igdat* "jobtools
1160: 22 20 22 6d 61 78 68 6f 6d 65 68 6f 73 74 6c 6f " "maxhomehostlo
1170: 61 64 22 20 64 65 66 61 75 6c 74 3a 20 33 2e 30 ad" default: 3.0
1180: 29 29 29 0a 20 20 20 20 3b 3b 20 77 65 20 77 61 ))). ;; we wa
1190: 6e 74 20 74 68 65 20 72 65 6d 6f 74 65 20 73 65 nt the remote se
11a0: 72 76 65 72 20 74 6f 20 73 74 61 72 74 20 69 6e rver to start in
11b0: 20 2a 74 6f 70 70 61 74 68 2a 20 73 6f 20 70 75 *toppath* so pu
11c0: 73 68 20 74 68 65 72 65 0a 20 20 20 20 28 70 75 sh there. (pu
11d0: 73 68 2d 64 69 72 65 63 74 6f 72 79 20 61 72 65 sh-directory are
11e0: 61 70 61 74 68 29 0a 20 20 20 20 28 64 65 62 75 apath). (debu
11f0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
1200: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
1210: 46 4f 3a 20 54 72 79 69 6e 67 20 74 6f 20 73 74 FO: Trying to st
1220: 61 72 74 20 73 65 72 76 65 72 20 28 22 20 63 6d art server (" cm
1230: 64 6c 6e 20 22 29 20 2e 2e 2e 22 29 0a 20 20 20 dln ") ...").
1240: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
1250: 6c 6f 67 2d 72 6f 74 61 74 65 29 0a 20 20 20 20 log-rotate).
1260: 0a 20 20 20 20 3b 3b 20 68 6f 73 74 2e 64 6f 6d . ;; host.dom
1270: 61 69 6e 2e 74 6c 64 20 6d 61 74 63 68 20 68 6f ain.tld match ho
1280: 73 74 3f 0a 20 20 20 20 28 69 66 20 28 61 6e 64 st?. (if (and
1290: 20 74 61 72 67 65 74 2d 68 6f 73 74 20 0a 09 20 target-host ..
12a0: 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 ;; look at t
12b0: 61 72 67 65 74 20 68 6f 73 74 2c 20 69 73 20 69 arget host, is i
12c0: 74 20 68 6f 73 74 2e 64 6f 6d 61 69 6e 2e 74 6c t host.domain.tl
12d0: 64 20 6f 72 20 69 70 20 61 64 64 72 65 73 73 20 d or ip address
12e0: 61 6e 64 20 64 6f 65 73 20 69 74 20 0a 09 20 20 and does it ..
12f0: 20 20 20 3b 3b 20 6d 61 74 63 68 20 63 75 72 72 ;; match curr
1300: 65 6e 74 20 69 70 20 6f 72 20 68 6f 73 74 6e 61 ent ip or hostna
1310: 6d 65 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 73 me.. (not (s
1320: 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 63 6f 6e tring-match (con
1330: 63 20 22 28 22 63 75 72 72 2d 68 6f 73 74 20 22 c "("curr-host "
1340: 7c 22 20 63 75 72 72 2d 68 6f 73 74 22 5c 5c 2e |" curr-host"\\.
1350: 2e 2a 29 22 29 20 74 61 72 67 65 74 2d 68 6f 73 .*)") target-hos
1360: 74 29 29 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 t)).. (not (
1370: 65 71 75 61 6c 3f 20 63 75 72 72 2d 69 70 20 74 equal? curr-ip t
1380: 61 72 67 65 74 2d 68 6f 73 74 29 29 29 0a 09 28 arget-host)))..(
1390: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
13a0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
13b0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
13c0: 22 53 74 61 72 74 69 6e 67 20 73 65 72 76 65 72 "Starting server
13d0: 20 6f 6e 20 22 20 74 61 72 67 65 74 2d 68 6f 73 on " target-hos
13e0: 74 20 22 2c 20 6c 6f 67 66 69 6c 65 20 69 73 20 t ", logfile is
13f0: 22 20 6c 6f 67 66 69 6c 65 29 0a 09 20 20 28 73 " logfile).. (s
1400: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
1410: 54 22 20 74 61 72 67 65 74 2d 68 6f 73 74 29 29 T" target-host))
1420: 29 0a 20 20 20 20 20 20 0a 20 20 20 20 28 73 65 ). . (se
1430: 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 tenv "TARGETHOST
1440: 5f 4c 4f 47 46 22 20 6c 6f 67 66 69 6c 65 29 0a _LOGF" logfile).
1450: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 (common:wait
1460: 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d -for-normalized-
1470: 6c 6f 61 64 20 6c 6f 61 64 2d 6c 69 6d 69 74 20 load load-limit
1480: 22 20 64 65 6c 61 79 69 6e 67 20 73 65 72 76 65 " delaying serve
1490: 72 20 73 74 61 72 74 20 64 75 65 20 74 6f 20 6c r start due to l
14a0: 6f 61 64 22 20 74 61 72 67 65 74 2d 68 6f 73 74 oad" target-host
14b0: 29 20 3b 3b 20 64 6f 20 6e 6f 74 20 74 72 79 20 ) ;; do not try
14c0: 73 74 61 72 74 69 6e 67 20 73 65 72 76 65 72 73 starting servers
14d0: 20 6f 6e 20 61 6e 20 61 6c 72 65 61 64 79 20 6f on an already o
14e0: 76 65 72 6c 6f 61 64 65 64 20 6d 61 63 68 69 6e verloaded machin
14f0: 65 2c 20 6a 75 73 74 20 77 61 69 74 20 66 6f 72 e, just wait for
1500: 65 76 65 72 0a 20 20 20 20 28 73 79 73 74 65 6d ever. (system
1510: 20 28 63 6f 6e 63 20 22 6e 62 66 61 6b 65 20 22 (conc "nbfake "
1520: 20 63 6d 64 6c 6e 29 29 0a 20 20 20 20 28 75 6e cmdln)). (un
1530: 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f setenv "TARGETHO
1540: 53 54 5f 4c 4f 47 46 22 29 0a 20 20 20 20 28 69 ST_LOGF"). (i
1550: 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 f (get-environme
1560: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 54 41 52 nt-variable "TAR
1570: 47 45 54 48 4f 53 54 22 29 28 75 6e 73 65 74 65 GETHOST")(unsete
1580: 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 29 nv "TARGETHOST")
1590: 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f ). (thread-jo
15a0: 69 6e 21 20 6c 6f 67 2d 72 6f 74 61 74 65 29 0a in! log-rotate).
15b0: 20 20 20 20 28 70 6f 70 2d 64 69 72 65 63 74 6f (pop-directo
15c0: 72 79 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 ry)))..;; given
15d0: 61 20 70 61 74 68 20 74 6f 20 61 20 73 65 72 76 a path to a serv
15e0: 65 72 20 6c 6f 67 20 72 65 74 75 72 6e 3a 20 68 er log return: h
15f0: 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 73 65 ost port startse
1600: 63 6f 6e 64 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 conds.;;.(define
1610: 20 28 73 65 72 76 65 72 3a 6c 6f 67 66 2d 67 65 (server:logf-ge
1620: 74 2d 73 74 61 72 74 2d 69 6e 66 6f 20 6c 6f 67 t-start-info log
1630: 66 29 0a 20 20 28 6c 65 74 20 28 28 72 78 20 28 f). (let ((rx (
1640: 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 52 20 regexp "^SERVER
1650: 53 54 41 52 54 45 44 3a 20 28 5c 5c 53 2b 29 3a STARTED: (\\S+):
1660: 28 5c 5c 64 2b 29 20 41 54 20 28 5b 5c 5c 64 5c (\\d+) AT ([\\d\
1670: 5c 2e 5d 2b 29 22 29 29 29 20 3b 3b 20 53 45 52 \.]+)"))) ;; SER
1680: 56 45 52 20 53 54 41 52 54 45 44 3a 20 68 6f 73 VER STARTED: hos
1690: 74 3a 70 6f 72 74 20 41 54 20 74 69 6d 65 73 65 t:port AT timese
16a0: 63 73 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 cs. (handle-e
16b0: 78 63 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a 09 xceptions..exn..
16c0: 28 6c 69 73 74 20 23 66 20 23 66 20 23 66 29 20 (list #f #f #f)
16d0: 3b 3b 20 6e 6f 20 69 64 65 61 20 77 68 61 74 20 ;; no idea what
16e0: 77 65 6e 74 20 77 72 6f 6e 67 2c 20 63 61 6c 6c went wrong, call
16f0: 20 69 74 20 61 20 62 61 64 20 73 65 72 76 65 72 it a bad server
1700: 0a 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 . (with-inp
1710: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 0a 09 20 20 ut-from-file..
1720: 6c 6f 67 66 0a 09 28 6c 61 6d 62 64 61 20 28 29 logf..(lambda ()
1730: 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 .. (let loop ((
1740: 69 6e 6c 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 inl (read-line)
1750: 29 0a 09 09 20 20 20 20 20 28 6c 6e 75 6d 20 30 )... (lnum 0
1760: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
1770: 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e (eof-object? in
1780: 6c 29 29 0a 09 09 28 6c 65 74 20 28 28 6d 6c 73 l))...(let ((mls
1790: 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 t (string-match
17a0: 72 78 20 69 6e 6c 29 29 29 0a 09 09 20 20 28 69 rx inl)))... (i
17b0: 66 20 28 6e 6f 74 20 6d 6c 73 74 29 0a 09 09 20 f (not mlst)...
17c0: 20 20 20 20 20 28 69 66 20 28 3c 20 6c 6e 75 6d (if (< lnum
17d0: 20 35 30 30 29 20 3b 3b 20 67 69 76 65 20 75 70 500) ;; give up
17e0: 20 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 35 30 if more than 50
17f0: 30 20 6c 69 6e 65 73 20 6f 66 20 73 65 72 76 65 0 lines of serve
1800: 72 20 6c 6f 67 20 72 65 61 64 0a 09 09 09 20 20 r log read....
1810: 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 (loop (read-line
1820: 29 28 2b 20 6c 6e 75 6d 20 31 29 29 0a 09 09 09 )(+ lnum 1))....
1830: 20 20 28 6c 69 73 74 20 23 66 20 23 66 20 23 66 (list #f #f #f
1840: 29 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 ))... (let
1850: 28 28 64 61 74 20 20 28 63 64 72 20 6d 6c 73 74 ((dat (cdr mlst
1860: 29 29 29 0a 09 09 09 28 6c 69 73 74 20 28 63 61 )))....(list (ca
1870: 72 20 64 61 74 29 20 3b 3b 20 68 6f 73 74 0a 09 r dat) ;; host..
1880: 09 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d .. (string-
1890: 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 64 61 >number (cadr da
18a0: 74 29 29 20 3b 3b 20 70 6f 72 74 0a 09 09 09 20 t)) ;; port....
18b0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
18c0: 6d 62 65 72 20 28 63 61 64 64 72 20 64 61 74 29 mber (caddr dat)
18d0: 29 29 29 29 29 0a 09 09 28 6c 69 73 74 20 23 66 )))))...(list #f
18e0: 20 23 66 20 23 66 29 29 29 29 29 29 29 29 0a 0a #f #f))))))))..
18f0: 3b 3b 20 67 65 74 20 61 20 6c 69 73 74 20 6f 66 ;; get a list of
1900: 20 73 65 72 76 65 72 73 20 77 69 74 68 20 61 6c servers with al
1910: 6c 20 72 65 6c 65 76 61 6e 74 20 64 61 74 61 0a l relevant data.
1920: 3b 3b 20 28 20 6d 6f 64 2d 74 69 6d 65 20 68 6f ;; ( mod-time ho
1930: 73 74 20 70 6f 72 74 20 73 74 61 72 74 2d 74 69 st port start-ti
1940: 6d 65 20 70 69 64 20 29 0a 3b 3b 0a 28 64 65 66 me pid ).;;.(def
1950: 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d ine (server:get-
1960: 6c 69 73 74 20 61 72 65 61 70 61 74 68 20 23 21 list areapath #!
1970: 6b 65 79 20 28 6c 69 6d 69 74 20 23 66 29 29 0a key (limit #f)).
1980: 20 20 28 6c 65 74 20 28 28 66 6e 61 6d 65 2d 72 (let ((fname-r
1990: 78 20 20 20 20 28 72 65 67 65 78 70 20 22 5e 28 x (regexp "^(
19a0: 7c 2e 2a 2f 29 73 65 72 76 65 72 2d 28 5c 5c 64 |.*/)server-(\\d
19b0: 2b 29 2d 28 5c 5c 53 2b 29 2e 6c 6f 67 24 22 29 +)-(\\S+).log$")
19c0: 29 0a 09 28 64 61 79 2d 73 65 63 6f 6e 64 73 20 )..(day-seconds
19d0: 28 2a 20 32 34 20 36 30 20 36 30 29 29 29 0a 20 (* 24 60 60))).
19e0: 20 20 20 3b 3b 20 69 66 20 74 68 65 20 64 69 72 ;; if the dir
19f0: 65 63 74 6f 72 79 20 65 78 69 73 74 73 20 63 6f ectory exists co
1a00: 6e 74 69 6e 75 65 20 74 6f 20 67 65 74 20 74 68 ntinue to get th
1a10: 65 20 6c 69 73 74 0a 20 20 20 20 3b 3b 20 6f 74 e list. ;; ot
1a20: 68 65 72 77 69 73 65 20 61 74 74 65 6d 70 74 20 herwise attempt
1a30: 74 6f 20 63 72 65 61 74 65 20 74 68 65 20 6c 6f to create the lo
1a40: 67 73 20 64 69 72 20 61 6e 64 20 74 68 65 6e 0a gs dir and then.
1a50: 20 20 20 20 3b 3b 20 63 6f 6e 74 69 6e 75 65 0a ;; continue.
1a60: 20 20 20 20 28 69 66 20 28 69 66 20 28 64 69 72 (if (if (dir
1a70: 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 28 ectory-exists? (
1a80: 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f conc areapath "/
1a90: 6c 6f 67 73 22 29 29 0a 09 20 20 20 20 27 28 29 logs")).. '()
1aa0: 0a 09 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d .. (if (file-
1ab0: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 61 72 write-access? ar
1ac0: 65 61 70 61 74 68 29 0a 09 09 28 62 65 67 69 6e eapath)...(begin
1ad0: 0a 09 09 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d ... (condition-
1ae0: 63 61 73 65 0a 09 09 20 20 20 20 20 20 28 63 72 case... (cr
1af0: 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 28 eate-directory (
1b00: 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f conc areapath "/
1b10: 6c 6f 67 73 22 29 20 23 74 29 0a 09 09 20 20 20 logs") #t)...
1b20: 20 28 65 78 6e 20 28 69 2f 6f 20 66 69 6c 65 29 (exn (i/o file)
1b30: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1b40: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1b50: 2a 20 22 45 52 52 4f 52 3a 20 43 61 6e 6e 6f 74 * "ERROR: Cannot
1b60: 20 63 72 65 61 74 65 20 64 69 72 65 63 74 6f 72 create director
1b70: 79 20 61 74 20 22 20 28 63 6f 6e 63 20 61 72 65 y at " (conc are
1b80: 61 70 61 74 68 20 22 2f 6c 6f 67 73 22 29 29 29 apath "/logs")))
1b90: 0a 09 09 20 20 20 20 28 65 78 6e 20 28 29 28 64 ... (exn ()(d
1ba0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
1bb0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1bc0: 22 45 52 52 4f 52 3a 20 55 6e 6b 6e 6f 77 6e 20 "ERROR: Unknown
1bd0: 65 72 72 6f 72 20 61 74 74 65 6d 74 70 69 6e 67 error attemtping
1be0: 20 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 6c to get server l
1bf0: 69 73 74 2e 22 29 29 29 0a 09 09 20 20 28 64 69 ist.")))... (di
1c00: 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 rectory-exists?
1c10: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 (conc areapath "
1c20: 2f 6c 6f 67 73 22 29 29 29 0a 09 09 27 28 29 29 /logs")))...'())
1c30: 29 0a 09 28 6c 65 74 2a 20 28 28 73 65 72 76 65 )..(let* ((serve
1c40: 72 2d 6c 6f 67 73 20 20 20 28 67 6c 6f 62 20 28 r-logs (glob (
1c50: 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f conc areapath "/
1c60: 6c 6f 67 73 2f 73 65 72 76 65 72 2d 2a 2e 6c 6f logs/server-*.lo
1c70: 67 22 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e g"))).. (n
1c80: 75 6d 2d 73 65 72 76 2d 6c 6f 67 73 20 28 6c 65 um-serv-logs (le
1c90: 6e 67 74 68 20 73 65 72 76 65 72 2d 6c 6f 67 73 ngth server-logs
1ca0: 29 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c ))).. (if (null
1cb0: 3f 20 73 65 72 76 65 72 2d 6c 6f 67 73 29 0a 09 ? server-logs)..
1cc0: 20 20 20 20 20 20 27 28 29 0a 09 20 20 20 20 20 '()..
1cd0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
1ce0: 20 20 28 63 61 72 20 73 65 72 76 65 72 2d 6c 6f (car server-lo
1cf0: 67 73 29 29 0a 09 09 09 20 28 74 61 6c 20 20 28 gs)).... (tal (
1d00: 63 64 72 20 73 65 72 76 65 72 2d 6c 6f 67 73 29 cdr server-logs)
1d10: 29 0a 09 09 09 20 28 72 65 73 20 27 28 29 29 29 ).... (res '()))
1d20: 0a 09 09 28 6c 65 74 2a 20 28 28 6d 6f 64 2d 74 ...(let* ((mod-t
1d30: 69 6d 65 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 ime (handle-exc
1d40: 65 70 74 69 6f 6e 73 0a 09 09 09 09 20 20 20 20 eptions.....
1d50: 20 20 65 78 6e 0a 09 09 09 09 20 20 20 20 20 20 exn.....
1d60: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
1d70: 29 20 3b 3b 20 30 0a 09 09 09 09 20 20 20 20 28 ) ;; 0..... (
1d80: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
1d90: 6e 2d 74 69 6d 65 20 68 65 64 29 29 29 20 3b 3b n-time hed))) ;;
1da0: 20 64 65 66 61 75 6c 74 20 74 6f 20 2a 76 65 72 default to *ver
1db0: 79 2a 20 6f 6c 64 20 73 6f 20 6c 6f 67 20 67 65 y* old so log ge
1dc0: 74 73 20 69 67 6e 6f 72 65 64 20 69 66 20 64 65 ts ignored if de
1dd0: 6c 65 74 65 64 0a 09 09 20 20 20 20 20 20 20 28 leted... (
1de0: 64 6f 77 6e 2d 74 69 6d 65 20 28 2d 20 28 63 75 down-time (- (cu
1df0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6d rrent-seconds) m
1e00: 6f 64 2d 74 69 6d 65 29 29 0a 09 09 20 20 20 20 od-time))...
1e10: 20 20 20 28 73 65 72 76 2d 64 61 74 20 20 28 69 (serv-dat (i
1e20: 66 20 28 6f 72 20 28 3c 20 6e 75 6d 2d 73 65 72 f (or (< num-ser
1e30: 76 2d 6c 6f 67 73 20 31 30 29 0a 09 09 09 09 20 v-logs 10).....
1e40: 20 09 20 20 28 3c 20 64 6f 77 6e 2d 74 69 6d 65 . (< down-time
1e50: 20 39 30 30 29 29 20 3b 3b 20 64 61 79 2d 73 65 900)) ;; day-se
1e60: 63 6f 6e 64 73 29 29 0a 09 09 09 09 20 20 20 20 conds)).....
1e70: 20 20 28 73 65 72 76 65 72 3a 6c 6f 67 66 2d 67 (server:logf-g
1e80: 65 74 2d 73 74 61 72 74 2d 69 6e 66 6f 20 68 65 et-start-info he
1e90: 64 29 0a 09 09 09 09 20 20 20 20 20 20 27 28 29 d)..... '()
1ea0: 29 29 20 3b 3b 20 64 6f 6e 27 74 20 77 61 73 74 )) ;; don't wast
1eb0: 65 20 74 69 6d 65 20 70 72 6f 63 65 73 73 69 6e e time processin
1ec0: 67 20 73 65 72 76 65 72 20 66 69 6c 65 73 20 6e g server files n
1ed0: 6f 74 20 74 6f 75 63 68 65 64 20 69 6e 20 74 68 ot touched in th
1ee0: 65 20 31 35 20 6d 69 6e 75 74 65 73 20 69 66 20 e 15 minutes if
1ef0: 74 68 65 72 65 20 61 72 65 20 6d 6f 72 65 20 74 there are more t
1f00: 68 61 6e 20 74 65 6e 20 73 65 72 76 65 72 73 20 han ten servers
1f10: 74 6f 20 6c 6f 6f 6b 20 61 74 0a 09 09 20 20 20 to look at...
1f20: 20 20 20 20 28 73 65 72 76 2d 72 65 63 20 28 63 (serv-rec (c
1f30: 6f 6e 73 20 6d 6f 64 2d 74 69 6d 65 20 73 65 72 ons mod-time ser
1f40: 76 2d 64 61 74 29 29 0a 09 09 20 20 20 20 20 20 v-dat))...
1f50: 20 28 66 6d 61 74 63 68 20 20 20 28 73 74 72 69 (fmatch (stri
1f60: 6e 67 2d 6d 61 74 63 68 20 66 6e 61 6d 65 2d 72 ng-match fname-r
1f70: 78 20 68 65 64 29 29 0a 09 09 20 20 20 20 20 20 x hed))...
1f80: 20 28 70 69 64 20 20 20 20 20 20 28 69 66 20 66 (pid (if f
1f90: 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 3e 6e match (string->n
1fa0: 75 6d 62 65 72 20 28 6c 69 73 74 2d 72 65 66 20 umber (list-ref
1fb0: 66 6d 61 74 63 68 20 32 29 29 20 23 66 29 29 0a fmatch 2)) #f)).
1fc0: 09 09 20 20 20 20 20 20 20 28 6e 65 77 2d 72 65 .. (new-re
1fd0: 73 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 73 65 s (if (null? se
1fe0: 72 76 2d 64 61 74 29 0a 09 09 09 09 20 20 20 20 rv-dat).....
1ff0: 20 72 65 73 0a 09 09 09 09 20 20 20 20 20 28 63 res..... (c
2000: 6f 6e 73 20 28 61 70 70 65 6e 64 20 73 65 72 76 ons (append serv
2010: 2d 72 65 63 20 28 6c 69 73 74 20 70 69 64 29 29 -rec (list pid))
2020: 20 72 65 73 29 29 29 29 0a 09 09 28 69 66 20 28 res))))...(if (
2030: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 null? tal)...
2040: 20 28 69 66 20 28 61 6e 64 20 6c 69 6d 69 74 0a (if (and limit.
2050: 09 09 09 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 ... (> (leng
2060: 74 68 20 6e 65 77 2d 72 65 73 29 20 6c 69 6d 69 th new-res) limi
2070: 74 29 29 0a 09 09 09 6e 65 77 2d 72 65 73 20 3b t))....new-res ;
2080: 3b 20 28 74 61 6b 65 20 6e 65 77 2d 72 65 73 20 ; (take new-res
2090: 6c 69 6d 69 74 29 20 20 3c 3d 20 6e 65 65 64 20 limit) <= need
20a0: 69 6e 74 65 6c 6c 69 67 65 6e 74 20 73 6f 72 74 intelligent sort
20b0: 69 6e 67 20 62 65 66 6f 72 65 20 74 68 69 73 20 ing before this
20c0: 77 69 6c 6c 20 77 6f 72 6b 0a 09 09 09 6e 65 77 will work....new
20d0: 2d 72 65 73 29 0a 09 09 20 20 20 20 28 6c 6f 6f -res)... (loo
20e0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
20f0: 74 61 6c 29 20 6e 65 77 2d 72 65 73 29 29 29 29 tal) new-res))))
2100: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
2110: 73 65 72 76 65 72 3a 67 65 74 2d 6e 75 6d 2d 61 server:get-num-a
2120: 6c 69 76 65 20 73 72 76 6c 73 74 29 0a 20 20 28 live srvlst). (
2130: 6c 65 74 20 28 28 6e 75 6d 2d 61 6c 69 76 65 20 let ((num-alive
2140: 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 0)). (for-eac
2150: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
2160: 73 65 72 76 65 72 29 0a 20 20 20 20 20 20 20 28 server). (
2170: 6d 61 74 63 68 2d 6c 65 74 20 28 28 28 6d 6f 64 match-let (((mod
2180: 2d 74 69 6d 65 20 68 6f 73 74 20 70 6f 72 74 20 -time host port
2190: 73 74 61 72 74 2d 74 69 6d 65 20 70 69 64 29 0a start-time pid).
21a0: 09 09 20 20 20 20 73 65 72 76 65 72 29 29 0a 09 .. server))..
21b0: 20 28 6c 65 74 2a 20 28 28 75 70 74 69 6d 65 20 (let* ((uptime
21c0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
21d0: 6f 6e 64 73 29 20 6d 6f 64 2d 74 69 6d 65 29 29 onds) mod-time))
21e0: 0a 09 09 28 72 75 6e 74 69 6d 65 20 28 69 66 20 ...(runtime (if
21f0: 73 74 61 72 74 2d 74 69 6d 65 0a 09 09 09 20 20 start-time....
2200: 20 20 20 28 2d 20 6d 6f 64 2d 74 69 6d 65 20 73 (- mod-time s
2210: 74 61 72 74 2d 74 69 6d 65 29 0a 09 09 09 20 20 tart-time)....
2220: 20 20 20 30 29 29 29 0a 09 20 20 20 28 69 66 20 0))).. (if
2230: 28 3c 20 75 70 74 69 6d 65 20 35 29 28 73 65 74 (< uptime 5)(set
2240: 21 20 6e 75 6d 2d 61 6c 69 76 65 20 28 2b 20 6e ! num-alive (+ n
2250: 75 6d 2d 61 6c 69 76 65 20 31 29 29 29 29 29 29 um-alive 1))))))
2260: 0a 20 20 20 20 20 73 72 76 6c 73 74 29 0a 20 20 . srvlst).
2270: 20 20 6e 75 6d 2d 61 6c 69 76 65 29 29 0a 0a 3b num-alive))..;
2280: 3b 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 6f ; given a list o
2290: 66 20 73 65 72 76 65 72 73 20 67 65 74 20 61 20 f servers get a
22a0: 6c 69 73 74 20 6f 66 20 76 61 6c 69 64 20 73 65 list of valid se
22b0: 72 76 65 72 73 2c 20 69 2e 65 2e 20 61 74 20 6c rvers, i.e. at l
22c0: 65 61 73 74 0a 3b 3b 20 31 30 20 73 65 63 6f 6e east.;; 10 secon
22d0: 64 73 20 6f 6c 64 2c 20 68 61 73 20 73 74 61 72 ds old, has star
22e0: 74 65 64 20 61 6e 64 20 69 73 20 6c 65 73 73 20 ted and is less
22f0: 74 68 61 6e 20 31 20 68 6f 75 72 20 6f 6c 64 20 than 1 hour old
2300: 61 6e 64 20 69 73 0a 3b 3b 20 61 63 74 69 76 65 and is.;; active
2310: 20 28 69 2e 65 2e 20 6d 6f 64 2d 74 69 6d 65 20 (i.e. mod-time
2320: 3c 20 31 30 20 73 65 63 6f 6e 64 73 0a 3b 3b 0a < 10 seconds.;;.
2330: 3b 3b 20 6d 6f 64 2d 74 69 6d 65 20 68 6f 73 74 ;; mod-time host
2340: 20 70 6f 72 74 20 73 74 61 72 74 2d 74 69 6d 65 port start-time
2350: 20 70 69 64 0a 3b 3b 0a 3b 3b 20 73 6f 72 74 20 pid.;;.;; sort
2360: 62 79 20 73 74 61 72 74 2d 74 69 6d 65 20 64 65 by start-time de
2370: 73 63 65 6e 64 69 6e 67 2e 20 49 2e 65 2e 20 67 scending. I.e. g
2380: 65 74 20 74 68 65 20 6f 6c 64 65 73 74 20 66 69 et the oldest fi
2390: 72 73 74 2e 20 59 6f 75 6e 67 20 73 65 72 76 65 rst. Young serve
23a0: 72 73 20 77 69 6c 6c 20 74 68 75 73 20 64 72 6f rs will thus dro
23b0: 70 20 6f 66 66 0a 3b 3b 20 61 6e 64 20 73 65 72 p off.;; and ser
23c0: 76 65 72 73 20 73 68 6f 75 6c 64 20 73 74 69 63 vers should stic
23d0: 6b 20 61 72 6f 75 6e 64 20 66 6f 72 20 61 62 6f k around for abo
23e0: 75 74 20 74 77 6f 20 68 6f 75 72 73 20 6f 72 20 ut two hours or
23f0: 73 6f 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 so..;;.(define (
2400: 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 20 server:get-best
2410: 73 72 76 6c 73 74 29 0a 20 20 28 6c 65 74 2a 20 srvlst). (let*
2420: 28 28 6e 75 6d 73 20 28 73 65 72 76 65 72 3a 67 ((nums (server:g
2430: 65 74 2d 6e 75 6d 2d 73 65 72 76 65 72 73 29 29 et-num-servers))
2440: 0a 09 20 28 6e 6f 77 20 20 28 63 75 72 72 65 6e .. (now (curren
2450: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 73 t-seconds)).. (s
2460: 6c 73 74 20 28 73 6f 72 74 0a 09 09 28 66 69 6c lst (sort...(fil
2470: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 72 65 63 ter (lambda (rec
2480: 29 0a 09 09 09 20 20 28 69 66 20 28 61 6e 64 20 ).... (if (and
2490: 28 6c 69 73 74 3f 20 72 65 63 29 0a 09 09 09 09 (list? rec).....
24a0: 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 72 65 (> (length re
24b0: 63 29 20 32 29 29 0a 09 09 09 20 20 20 20 20 20 c) 2))....
24c0: 28 6c 65 74 20 28 28 73 74 61 72 74 2d 74 69 6d (let ((start-tim
24d0: 65 20 28 6c 69 73 74 2d 72 65 66 20 72 65 63 20 e (list-ref rec
24e0: 33 29 29 0a 09 09 09 09 20 20 20 20 28 6d 6f 64 3))..... (mod
24f0: 2d 74 69 6d 65 20 20 20 28 6c 69 73 74 2d 72 65 -time (list-re
2500: 66 20 72 65 63 20 30 29 29 29 0a 09 09 09 09 3b f rec 0))).....;
2510: 3b 20 28 70 72 69 6e 74 20 22 73 74 61 72 74 2d ; (print "start-
2520: 74 69 6d 65 3a 20 22 20 73 74 61 72 74 2d 74 69 time: " start-ti
2530: 6d 65 20 22 20 6d 6f 64 2d 74 69 6d 65 3a 20 22 me " mod-time: "
2540: 20 6d 6f 64 2d 74 69 6d 65 29 0a 09 09 09 09 28 mod-time).....(
2550: 61 6e 64 20 73 74 61 72 74 2d 74 69 6d 65 20 6d and start-time m
2560: 6f 64 2d 74 69 6d 65 0a 09 09 09 09 20 20 20 20 od-time.....
2570: 20 28 3e 20 28 2d 20 6e 6f 77 20 73 74 61 72 74 (> (- now start
2580: 2d 74 69 6d 65 29 20 30 29 20 20 20 20 3b 3b 20 -time) 0) ;;
2590: 62 65 65 6e 20 72 75 6e 6e 69 6e 67 20 61 74 20 been running at
25a0: 6c 65 61 73 74 20 30 20 73 65 63 6f 6e 64 73 0a least 0 seconds.
25b0: 09 09 09 09 20 20 20 20 20 28 3c 20 28 2d 20 6e .... (< (- n
25c0: 6f 77 20 6d 6f 64 2d 74 69 6d 65 29 20 20 20 31 ow mod-time) 1
25d0: 36 29 20 20 20 3b 3b 20 73 74 69 6c 6c 20 61 6c 6) ;; still al
25e0: 69 76 65 20 2d 20 66 69 6c 65 20 74 6f 75 63 68 ive - file touch
25f0: 65 64 20 69 6e 20 6c 61 73 74 20 31 36 20 73 65 ed in last 16 se
2600: 63 6f 6e 64 73 0a 09 09 09 09 20 20 20 20 20 28 conds..... (
2610: 3c 20 28 2d 20 6e 6f 77 20 73 74 61 72 74 2d 74 < (- now start-t
2620: 69 6d 65 29 20 20 20 20 20 20 20 0a 09 09 09 09 ime) .....
2630: 09 28 2b 20 28 2d 20 28 73 74 72 69 6e 67 2d 3e .(+ (- (string->
2640: 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 number (or (conf
2650: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
2660: 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 igdat* "server"
2670: 22 72 75 6e 74 69 6d 65 22 29 20 22 33 36 30 30 "runtime") "3600
2680: 22 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 31 "))...... 1
2690: 38 30 29 0a 09 09 09 09 09 20 20 20 28 72 61 6e 80)...... (ran
26a0: 64 6f 6d 20 33 36 30 29 29 29 20 3b 3b 20 75 6e dom 360))) ;; un
26b0: 64 65 72 20 6f 6e 65 20 68 6f 75 72 20 72 75 6e der one hour run
26c0: 6e 69 6e 67 20 74 69 6d 65 20 2b 2f 2d 20 31 38 ning time +/- 18
26d0: 30 0a 09 09 09 09 20 20 20 20 20 29 29 0a 09 09 0..... ))...
26e0: 09 20 20 20 20 20 20 23 66 29 29 0a 09 09 09 73 . #f))....s
26f0: 72 76 6c 73 74 29 0a 09 09 28 6c 61 6d 62 64 61 rvlst)...(lambda
2700: 20 28 61 20 62 29 0a 09 09 20 20 28 3c 20 28 6c (a b)... (< (l
2710: 69 73 74 2d 72 65 66 20 61 20 33 29 0a 09 09 20 ist-ref a 3)...
2720: 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 62 20 (list-ref b
2730: 33 29 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 3)))))). (if
2740: 28 3e 20 28 6c 65 6e 67 74 68 20 73 6c 73 74 29 (> (length slst)
2750: 20 6e 75 6d 73 29 0a 09 28 74 61 6b 65 20 73 6c nums)..(take sl
2760: 73 74 20 6e 75 6d 73 29 0a 09 73 6c 73 74 29 29 st nums)..slst))
2770: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 )..(define (serv
2780: 65 72 3a 67 65 74 2d 66 69 72 73 74 2d 62 65 73 er:get-first-bes
2790: 74 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 6c t areapath). (l
27a0: 65 74 20 28 28 73 72 76 72 73 20 28 73 65 72 76 et ((srvrs (serv
27b0: 65 72 3a 67 65 74 2d 62 65 73 74 20 28 73 65 72 er:get-best (ser
27c0: 76 65 72 3a 67 65 74 2d 6c 69 73 74 20 61 72 65 ver:get-list are
27d0: 61 70 61 74 68 29 29 29 29 0a 20 20 20 20 28 69 apath)))). (i
27e0: 66 20 28 61 6e 64 20 73 72 76 72 73 0a 09 20 20 f (and srvrs..
27f0: 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 73 (not (null? s
2800: 72 76 72 73 29 29 29 0a 09 28 63 61 72 20 73 72 rvrs)))..(car sr
2810: 76 72 73 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 vrs)..#f)))..(de
2820: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 fine (server:get
2830: 2d 72 61 6e 64 2d 62 65 73 74 20 61 72 65 61 70 -rand-best areap
2840: 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 73 72 ath). (let ((sr
2850: 76 72 73 20 28 73 65 72 76 65 72 3a 67 65 74 2d vrs (server:get-
2860: 62 65 73 74 20 28 73 65 72 76 65 72 3a 67 65 74 best (server:get
2870: 2d 6c 69 73 74 20 61 72 65 61 70 61 74 68 29 29 -list areapath))
2880: 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 )). (if (and
2890: 28 6c 69 73 74 3f 20 73 72 76 72 73 29 0a 09 20 (list? srvrs)..
28a0: 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (not (null?
28b0: 73 72 76 72 73 29 29 29 0a 09 28 6c 65 74 2a 20 srvrs)))..(let*
28c0: 28 28 6c 65 6e 20 28 6c 65 6e 67 74 68 20 73 72 ((len (length sr
28d0: 76 72 73 29 29 0a 09 20 20 20 20 20 20 20 28 69 vrs)).. (i
28e0: 64 78 20 28 72 61 6e 64 6f 6d 20 6c 65 6e 29 29 dx (random len))
28f0: 29 0a 09 20 20 28 6c 69 73 74 2d 72 65 66 20 73 ).. (list-ref s
2900: 72 76 72 73 20 69 64 78 29 29 0a 09 23 66 29 29 rvrs idx))..#f))
2910: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 )...(define (ser
2920: 76 65 72 3a 72 65 63 6f 72 64 2d 3e 75 72 6c 20 ver:record->url
2930: 73 65 72 76 72 29 0a 20 20 28 6d 61 74 63 68 2d servr). (match-
2940: 6c 65 74 20 28 28 28 6d 6f 64 2d 74 69 6d 65 20 let (((mod-time
2950: 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 2d host port start-
2960: 74 69 6d 65 20 70 69 64 29 0a 09 20 20 20 20 20 time pid)..
2970: 20 20 73 65 72 76 72 29 29 0a 20 20 20 20 28 69 servr)). (i
2980: 66 20 28 61 6e 64 20 68 6f 73 74 20 70 6f 72 74 f (and host port
2990: 29 0a 09 28 63 6f 6e 63 20 68 6f 73 74 20 22 3a )..(conc host ":
29a0: 22 20 70 6f 72 74 29 0a 09 23 66 29 29 29 0a 0a " port)..#f)))..
29b0: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
29c0: 67 65 74 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 get-client-signa
29d0: 74 75 72 65 29 20 3b 3b 20 42 42 3e 20 77 68 79 ture) ;; BB> why
29e0: 20 69 73 20 74 68 69 73 20 70 72 6f 63 20 6e 61 is this proc na
29f0: 6d 65 64 20 22 67 65 74 2d 22 3f 20 20 69 74 20 med "get-"? it
2a00: 72 65 74 75 72 6e 73 20 6e 6f 74 68 69 6e 67 20 returns nothing
2a10: 2d 2d 20 73 65 74 21 20 68 61 73 20 6e 6f 74 20 -- set! has not
2a20: 72 65 74 75 72 6e 20 76 61 6c 75 65 2e 0a 20 20 return value..
2a30: 28 69 66 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 (if *my-client-s
2a40: 69 67 6e 61 74 75 72 65 2a 20 2a 6d 79 2d 63 6c ignature* *my-cl
2a50: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 0a ient-signature*.
2a60: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 69 67 (let ((sig
2a70: 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e (server:mk-sign
2a80: 61 74 75 72 65 29 29 29 0a 20 20 20 20 20 20 20 ature))).
2a90: 20 28 73 65 74 21 20 2a 6d 79 2d 63 6c 69 65 6e (set! *my-clien
2aa0: 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 73 69 67 t-signature* sig
2ab0: 29 0a 20 20 20 20 20 20 20 20 2a 6d 79 2d 63 6c ). *my-cl
2ac0: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 ient-signature*)
2ad0: 29 29 0a 0a 3b 3b 20 6b 69 6e 64 20 73 74 61 72 ))..;; kind star
2ae0: 74 20 75 70 20 6f 66 20 73 65 72 76 65 72 73 2c t up of servers,
2af0: 20 77 61 69 74 20 34 30 20 73 65 63 6f 6e 64 73 wait 40 seconds
2b00: 20 62 65 66 6f 72 65 20 61 6c 6c 6f 77 69 6e 67 before allowing
2b10: 20 61 6e 6f 74 68 65 72 20 73 65 72 76 65 72 20 another server
2b20: 66 6f 72 20 61 20 67 69 76 65 6e 0a 3b 3b 20 72 for a given.;; r
2b30: 75 6e 2d 69 64 20 74 6f 20 62 65 20 6c 61 75 6e un-id to be laun
2b40: 63 68 65 64 0a 28 64 65 66 69 6e 65 20 28 73 65 ched.(define (se
2b50: 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 61 72 rver:kind-run ar
2b60: 65 61 70 61 74 68 29 0a 20 20 28 69 66 20 28 6e eapath). (if (n
2b70: 6f 74 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b ot (server:check
2b80: 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 -if-running area
2b90: 70 61 74 68 29 29 20 3b 3b 20 77 68 79 20 74 72 path)) ;; why tr
2ba0: 79 20 69 66 20 74 68 65 72 65 20 69 73 20 61 6c y if there is al
2bb0: 72 65 61 64 79 20 61 20 73 65 72 76 65 72 20 72 ready a server r
2bc0: 75 6e 6e 69 6e 67 3f 0a 20 20 20 20 20 20 28 6c unning?. (l
2bd0: 65 74 2a 20 28 28 6c 61 73 74 2d 72 75 6e 2d 64 et* ((last-run-d
2be0: 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
2bf0: 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 72 76 ef/default *serv
2c00: 65 72 2d 6b 69 6e 64 2d 72 75 6e 2a 20 61 72 65 er-kind-run* are
2c10: 61 70 61 74 68 20 27 28 30 20 30 29 29 29 20 3b apath '(0 0))) ;
2c20: 3b 20 63 61 6c 6c 6e 75 6d 2c 20 77 68 65 6e 72 ; callnum, whenr
2c30: 75 6e 0a 09 20 20 20 20 20 28 63 61 6c 6c 2d 6e un.. (call-n
2c40: 75 6d 20 20 20 20 20 28 63 61 72 20 6c 61 73 74 um (car last
2c50: 2d 72 75 6e 2d 64 61 74 29 29 0a 09 20 20 20 20 -run-dat))..
2c60: 20 28 77 68 65 6e 2d 72 75 6e 20 20 20 20 20 28 (when-run (
2c70: 63 61 64 72 20 6c 61 73 74 2d 72 75 6e 2d 64 61 cadr last-run-da
2c80: 74 29 29 0a 09 20 20 20 20 20 28 72 75 6e 2d 64 t)).. (run-d
2c90: 65 6c 61 79 20 20 20 20 28 2b 20 28 63 61 73 65 elay (+ (case
2ca0: 20 63 61 6c 6c 2d 6e 75 6d 0a 09 09 09 09 28 28 call-num.....((
2cb0: 30 29 20 20 20 20 30 29 0a 09 09 09 09 28 28 31 0) 0).....((1
2cc0: 29 20 20 20 32 30 29 0a 09 09 09 09 28 28 32 29 ) 20).....((2)
2cd0: 20 20 33 30 30 29 0a 09 09 09 09 28 65 6c 73 65 300).....(else
2ce0: 20 36 30 30 29 29 0a 09 09 09 20 20 20 20 20 20 600))....
2cf0: 28 72 61 6e 64 6f 6d 20 35 29 29 29 20 20 20 3b (random 5))) ;
2d00: 3b 20 61 64 64 20 61 20 73 6d 61 6c 6c 20 72 61 ; add a small ra
2d10: 6e 64 6f 6d 20 6e 75 6d 62 65 72 20 6a 75 73 74 ndom number just
2d20: 20 69 6e 20 63 61 73 65 20 61 20 6c 6f 74 20 6f in case a lot o
2d30: 66 20 6a 6f 62 73 20 68 69 74 20 74 68 65 20 77 f jobs hit the w
2d40: 6f 72 6b 20 68 6f 73 74 73 20 73 69 6d 75 6c 74 ork hosts simult
2d50: 61 6e 65 6f 75 73 6c 79 0a 09 20 20 20 20 20 28 aneously.. (
2d60: 6c 6f 63 6b 2d 66 69 6c 65 20 20 20 20 28 63 6f lock-file (co
2d70: 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f 6c 6f nc areapath "/lo
2d80: 67 73 2f 73 65 72 76 65 72 2d 73 74 61 72 74 2e gs/server-start.
2d90: 6c 6f 63 6b 22 29 29 29 0a 09 28 69 66 09 28 3e lock")))..(if.(>
2da0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
2db0: 6f 6e 64 73 29 20 77 68 65 6e 2d 72 75 6e 29 20 onds) when-run)
2dc0: 72 75 6e 2d 64 65 6c 61 79 29 0a 09 09 28 62 65 run-delay)...(be
2dd0: 67 69 6e 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a gin... (common:
2de0: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
2df0: 2d 61 6e 64 2d 77 61 69 74 20 6c 6f 63 6b 2d 66 -and-wait lock-f
2e00: 69 6c 65 20 65 78 70 69 72 65 2d 74 69 6d 65 3a ile expire-time:
2e10: 20 31 35 29 0a 09 09 20 20 28 73 65 72 76 65 72 15)... (server
2e20: 3a 72 75 6e 20 61 72 65 61 70 61 74 68 29 0a 09 :run areapath)..
2e30: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
2e40: 21 20 35 29 20 3b 3b 20 64 6f 6e 27 74 20 72 65 ! 5) ;; don't re
2e50: 6c 65 61 73 65 20 74 68 65 20 6c 6f 63 6b 20 66 lease the lock f
2e60: 6f 72 20 61 74 20 6c 65 61 73 74 20 61 20 66 65 or at least a fe
2e70: 77 20 73 65 63 6f 6e 64 73 0a 09 09 20 20 28 63 w seconds... (c
2e80: 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c ommon:simple-fil
2e90: 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c e-release-lock l
2ea0: 6f 63 6b 2d 66 69 6c 65 29 29 29 0a 09 28 68 61 ock-file)))..(ha
2eb0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 73 sh-table-set! *s
2ec0: 65 72 76 65 72 2d 6b 69 6e 64 2d 72 75 6e 2a 20 erver-kind-run*
2ed0: 61 72 65 61 70 61 74 68 20 28 6c 69 73 74 20 28 areapath (list (
2ee0: 2b 20 63 61 6c 6c 2d 6e 75 6d 20 31 29 28 63 75 + call-num 1)(cu
2ef0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
2f00: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
2f10: 72 76 65 72 3a 73 74 61 72 74 2d 61 6e 64 2d 77 rver:start-and-w
2f20: 61 69 74 20 61 72 65 61 70 61 74 68 20 23 21 6b ait areapath #!k
2f30: 65 79 20 28 74 69 6d 65 6f 75 74 20 36 30 29 29 ey (timeout 60))
2f40: 0a 20 20 28 6c 65 74 20 28 28 67 69 76 65 2d 75 . (let ((give-u
2f50: 70 2d 74 69 6d 65 20 28 2b 20 28 63 75 72 72 65 p-time (+ (curre
2f60: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 74 69 6d 65 nt-seconds) time
2f70: 6f 75 74 29 29 29 0a 20 20 20 20 28 6c 65 74 20 out))). (let
2f80: 6c 6f 6f 70 20 28 28 73 65 72 76 65 72 2d 75 72 loop ((server-ur
2f90: 6c 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d l (server:check-
2fa0: 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 if-running areap
2fb0: 61 74 68 29 29 0a 09 20 20 20 20 20 20 20 28 74 ath)).. (t
2fc0: 72 79 2d 6e 75 6d 20 20 20 20 30 29 29 0a 20 20 ry-num 0)).
2fd0: 20 20 20 20 28 69 66 20 28 6f 72 20 73 65 72 76 (if (or serv
2fe0: 65 72 2d 75 72 6c 0a 09 20 20 20 20 20 20 28 3e er-url.. (>
2ff0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
3000: 73 29 20 67 69 76 65 2d 75 70 2d 74 69 6d 65 29 s) give-up-time)
3010: 29 20 3b 3b 20 73 65 72 76 65 72 2d 75 72 6c 20 ) ;; server-url
3020: 77 69 6c 6c 20 62 65 20 23 66 20 69 66 20 6e 6f will be #f if no
3030: 20 73 65 72 76 65 72 20 61 76 61 69 6c 61 62 6c server availabl
3040: 65 2e 0a 09 20 20 73 65 72 76 65 72 2d 75 72 6c e... server-url
3050: 0a 09 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 6f .. (let ((num-o
3060: 6b 20 28 6c 65 6e 67 74 68 20 28 73 65 72 76 65 k (length (serve
3070: 72 3a 67 65 74 2d 62 65 73 74 20 28 73 65 72 76 r:get-best (serv
3080: 65 72 3a 67 65 74 2d 6c 69 73 74 20 61 72 65 61 er:get-list area
3090: 70 61 74 68 29 29 29 29 29 0a 09 20 20 20 20 28 path))))).. (
30a0: 69 66 20 28 61 6e 64 20 28 3e 20 74 72 79 2d 6e if (and (> try-n
30b0: 75 6d 20 30 29 20 20 3b 3b 20 66 69 72 73 74 20 um 0) ;; first
30c0: 74 69 6d 65 20 74 68 72 6f 75 67 68 20 73 69 6d time through sim
30d0: 70 6c 79 20 77 61 69 74 20 61 20 6c 69 74 74 6c ply wait a littl
30e0: 65 20 77 68 69 6c 65 20 74 68 65 6e 20 74 72 79 e while then try
30f0: 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 28 3c again... (<
3100: 20 6e 75 6d 2d 6f 6b 20 31 29 29 20 20 3b 3b 20 num-ok 1)) ;;
3110: 69 66 20 74 68 65 72 65 20 61 72 65 20 6e 6f 20 if there are no
3120: 64 65 63 65 6e 74 20 63 61 6e 64 69 64 61 74 65 decent candidate
3130: 73 20 66 6f 72 20 73 65 72 76 65 72 73 20 74 68 s for servers th
3140: 65 6e 20 74 72 79 20 73 74 61 72 74 69 6e 67 20 en try starting
3150: 61 20 6e 65 77 20 6f 6e 65 0a 09 09 28 73 65 72 a new one...(ser
3160: 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 61 72 65 ver:kind-run are
3170: 61 70 61 74 68 29 29 0a 09 20 20 20 20 28 74 68 apath)).. (th
3180: 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 read-sleep! 5)..
3190: 20 20 20 20 28 6c 6f 6f 70 20 28 73 65 72 76 65 (loop (serve
31a0: 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 r:check-if-runni
31b0: 6e 67 20 61 72 65 61 70 61 74 68 29 0a 09 09 20 ng areapath)...
31c0: 20 28 2b 20 74 72 79 2d 6e 75 6d 20 31 29 29 29 (+ try-num 1)))
31d0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 65 ))))..(define se
31e0: 72 76 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e 67 rver:try-running
31f0: 20 73 65 72 76 65 72 3a 72 75 6e 29 20 3b 3b 20 server:run) ;;
3200: 74 68 65 72 65 20 69 73 20 6e 6f 20 6d 6f 72 65 there is no more
3210: 20 70 65 72 2d 72 75 6e 20 73 65 72 76 65 72 73 per-run servers
3220: 20 3b 3b 20 52 45 4d 4f 56 45 20 4d 45 2e 20 42 ;; REMOVE ME. B
3230: 55 47 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 UG...(define (se
3240: 72 76 65 72 3a 67 65 74 2d 6e 75 6d 2d 73 65 72 rver:get-num-ser
3250: 76 65 72 73 20 23 21 6b 65 79 20 28 6e 75 6d 73 vers #!key (nums
3260: 65 72 76 65 72 73 20 32 29 29 0a 20 20 28 6c 65 ervers 2)). (le
3270: 74 20 28 28 6e 73 20 28 73 74 72 69 6e 67 2d 3e t ((ns (string->
3280: 6e 75 6d 62 65 72 0a 09 20 20 20 20 20 28 6f 72 number.. (or
3290: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
32a0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
32b0: 72 76 65 72 22 20 22 6e 75 6d 73 65 72 76 65 72 rver" "numserver
32c0: 73 22 29 20 22 6e 6f 74 61 6e 75 6d 62 65 72 22 s") "notanumber"
32d0: 29 29 29 29 0a 20 20 20 20 28 6f 72 20 6e 73 20 )))). (or ns
32e0: 6e 75 6d 73 65 72 76 65 72 73 29 29 29 0a 0a 3b numservers)))..;
32f0: 3b 20 6e 6f 20 6c 6f 6e 67 65 72 20 63 61 72 65 ; no longer care
3300: 20 69 66 20 6d 75 6c 74 69 70 6c 65 20 73 65 72 if multiple ser
3310: 76 65 72 73 20 61 72 65 20 73 74 61 72 74 65 64 vers are started
3320: 20 62 79 20 61 63 63 69 64 65 6e 74 2e 20 6f 6c by accident. ol
3330: 64 65 72 20 73 65 72 76 65 72 73 20 77 69 6c 6c der servers will
3340: 20 64 72 6f 70 20 6f 66 66 20 69 6e 20 74 69 6d drop off in tim
3350: 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 e..;;.(define (s
3360: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
3370: 75 6e 6e 69 6e 67 20 61 72 65 61 70 61 74 68 29 unning areapath)
3380: 20 3b 3b 20 20 23 21 6b 65 79 20 28 6e 75 6d 73 ;; #!key (nums
3390: 65 72 76 65 72 73 20 22 32 22 29 29 0a 20 20 28 ervers "2")). (
33a0: 6c 65 74 2a 20 28 28 6e 73 20 20 20 20 20 20 20 let* ((ns
33b0: 20 20 20 20 20 28 73 65 72 76 65 72 3a 67 65 74 (server:get
33c0: 2d 6e 75 6d 2d 73 65 72 76 65 72 73 29 29 0a 09 -num-servers))..
33d0: 20 28 73 65 72 76 65 72 73 20 20 20 20 20 20 20 (servers
33e0: 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 (server:get-best
33f0: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6c 69 73 (server:get-lis
3400: 74 20 61 72 65 61 70 61 74 68 29 29 29 29 0a 20 t areapath)))).
3410: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 73 65 ;; (print "se
3420: 72 76 65 72 73 3a 20 22 20 73 65 72 76 65 72 73 rvers: " servers
3430: 20 22 20 6e 73 3a 20 22 20 6e 73 29 0a 20 20 20 " ns: " ns).
3440: 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 73 65 (if (or (and se
3450: 72 76 65 72 73 0a 09 09 20 28 6e 75 6c 6c 3f 20 rvers... (null?
3460: 73 65 72 76 65 72 73 29 29 0a 09 20 20 20 20 28 servers)).. (
3470: 6e 6f 74 20 73 65 72 76 65 72 73 29 0a 09 20 20 not servers)..
3480: 20 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 73 65 (and (list? se
3490: 72 76 65 72 73 29 0a 09 09 20 28 3c 20 28 6c 65 rvers)... (< (le
34a0: 6e 67 74 68 20 73 65 72 76 65 72 73 29 20 28 72 ngth servers) (r
34b0: 61 6e 64 6f 6d 20 6e 73 29 29 29 29 20 3b 3b 20 andom ns)))) ;;
34c0: 73 6f 6d 65 77 68 65 72 65 20 62 65 74 77 65 65 somewhere betwee
34d0: 6e 20 30 20 61 6e 64 20 6e 75 6d 73 65 72 76 65 n 0 and numserve
34e0: 72 73 0a 20 20 20 20 20 20 20 20 23 66 0a 20 20 rs. #f.
34f0: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
3500: 28 28 68 65 64 20 28 63 61 72 20 73 65 72 76 65 ((hed (car serve
3510: 72 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 rs)).
3520: 20 20 20 20 20 20 20 20 28 74 61 6c 20 28 63 64 (tal (cd
3530: 72 20 73 65 72 76 65 72 73 29 29 29 0a 20 20 20 r servers))).
3540: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 (let ((re
3550: 73 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d s (server:check-
3560: 73 65 72 76 65 72 20 68 65 64 29 29 29 0a 20 20 server hed))).
3570: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 72 65 (if re
3580: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
3590: 20 20 72 65 73 0a 20 20 20 20 20 20 20 20 20 20 res.
35a0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
35b0: 20 74 61 6c 29 0a 20 20 20 20 20 20 20 20 20 20 tal).
35c0: 20 20 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 #f.
35d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
35e0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
35f0: 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 (cdr tal))))))))
3600: 29 0a 0a 3b 3b 20 70 69 6e 67 20 74 68 65 20 67 )..;; ping the g
3610: 69 76 65 6e 20 73 65 72 76 65 72 0a 3b 3b 0a 28 iven server.;;.(
3620: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 63 define (server:c
3630: 68 65 63 6b 2d 73 65 72 76 65 72 20 73 65 72 76 heck-server serv
3640: 65 72 2d 72 65 63 6f 72 64 29 0a 20 20 28 6c 65 er-record). (le
3650: 74 2a 20 28 28 73 65 72 76 65 72 2d 75 72 6c 20 t* ((server-url
3660: 28 73 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e (server:record->
3670: 75 72 6c 20 73 65 72 76 65 72 2d 72 65 63 6f 72 url server-recor
3680: 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 65 d)). (re
3690: 73 20 20 20 20 20 20 20 20 28 63 61 73 65 20 2a s (case *
36a0: 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 0a transport-type*.
36b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36c0: 20 20 20 20 20 20 20 28 28 68 74 74 70 29 28 73 ((http)(s
36d0: 65 72 76 65 72 3a 70 69 6e 67 20 73 65 72 76 65 erver:ping serve
36e0: 72 2d 75 72 6c 29 29 0a 20 20 20 20 20 20 20 20 r-url)).
36f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
3700: 3b 20 28 28 6e 6d 73 67 29 28 6e 6d 73 67 2d 74 ; ((nmsg)(nmsg-t
3710: 72 61 6e 73 70 6f 72 74 3a 70 69 6e 67 20 28 74 ransport:ping (t
3720: 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 asks:hostinfo-ge
3730: 74 2d 69 6e 74 65 72 66 61 63 65 20 73 65 72 76 t-interface serv
3740: 65 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 er).
3750: 20 20 20 20 20 20 20 20 20 20 20 29 29 29 0a 20 ))).
3760: 20 20 20 28 69 66 20 72 65 73 0a 20 20 20 20 20 (if res.
3770: 20 20 20 73 65 72 76 65 72 2d 75 72 6c 0a 09 23 server-url..#
3780: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 f)))..(define (s
3790: 65 72 76 65 72 3a 6b 69 6c 6c 20 73 65 72 76 72 erver:kill servr
37a0: 29 0a 20 20 28 6d 61 74 63 68 2d 6c 65 74 20 28 ). (match-let (
37b0: 28 28 6d 6f 64 2d 74 69 6d 65 20 68 6f 73 74 6e ((mod-time hostn
37c0: 61 6d 65 20 70 6f 72 74 20 73 74 61 72 74 2d 74 ame port start-t
37d0: 69 6d 65 20 70 69 64 29 0a 09 20 20 20 20 20 20 ime pid)..
37e0: 20 73 65 72 76 72 29 29 0a 20 20 20 20 28 74 61 servr)). (ta
37f0: 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 20 sks:kill-server
3800: 68 6f 73 74 6e 61 6d 65 20 70 69 64 29 29 29 0a hostname pid))).
3810: 0a 3b 3b 20 63 61 6c 6c 65 64 20 69 6e 20 6d 65 .;; called in me
3820: 67 61 74 65 73 74 2e 73 63 6d 2c 20 68 6f 73 74 gatest.scm, host
3830: 2d 70 6f 72 74 20 69 73 20 73 74 72 69 6e 67 20 -port is string
3840: 68 6f 73 74 6e 61 6d 65 3a 70 6f 72 74 0a 3b 3b hostname:port.;;
3850: 0a 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 .;; NOTE: This i
3860: 73 20 4e 4f 54 20 63 61 6c 6c 65 64 20 64 69 72 s NOT called dir
3870: 65 63 74 6c 79 20 66 72 6f 6d 20 63 6c 69 65 6e ectly from clien
3880: 74 73 20 61 73 20 6e 6f 74 20 61 6c 6c 20 74 72 ts as not all tr
3890: 61 6e 73 70 6f 72 74 73 20 73 75 70 70 6f 72 74 ansports support
38a0: 20 61 20 63 6c 69 65 6e 74 20 72 75 6e 6e 69 6e a client runnin
38b0: 67 0a 3b 3b 20 20 20 20 20 20 20 69 6e 20 74 68 g.;; in th
38c0: 65 20 73 61 6d 65 20 70 72 6f 63 65 73 73 20 61 e same process a
38d0: 73 20 74 68 65 20 73 65 72 76 65 72 2e 0a 3b 3b s the server..;;
38e0: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
38f0: 3a 70 69 6e 67 20 68 6f 73 74 2d 70 6f 72 74 2d :ping host-port-
3900: 69 6e 20 23 21 6b 65 79 20 28 64 6f 2d 65 78 69 in #!key (do-exi
3910: 74 20 23 66 29 29 0a 20 20 28 6c 65 74 20 28 28 t #f)). (let ((
3920: 68 6f 73 74 3a 70 6f 72 74 20 28 69 66 20 28 6e host:port (if (n
3930: 6f 74 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 ot host-port-in)
3940: 20 3b 3b 20 75 73 65 20 72 65 61 64 2d 64 6f 74 ;; use read-dot
3950: 73 65 72 76 65 72 20 74 6f 20 66 69 6e 64 0a 09 server to find..
3960: 09 20 20 20 20 20 20 20 23 66 20 3b 3b 20 28 73 . #f ;; (s
3970: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
3980: 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a unning *toppath*
3990: 29 0a 09 09 3b 3b 20 28 69 66 20 28 6e 75 6d 62 )...;; (if (numb
39a0: 65 72 3f 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e er? host-port-in
39b0: 29 20 3b 3b 20 77 65 20 77 65 72 65 20 68 61 6e ) ;; we were han
39c0: 64 65 64 20 61 20 73 65 72 76 65 72 2d 69 64 0a ded a server-id.
39d0: 09 09 3b 3b 20 09 20 20 20 28 6c 65 74 20 28 28 ..;; . (let ((
39e0: 73 72 65 63 20 28 74 61 73 6b 73 3a 67 65 74 2d srec (tasks:get-
39f0: 73 65 72 76 65 72 2d 62 79 2d 69 64 20 28 64 62 server-by-id (db
3a00: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 :delay-if-busy (
3a10: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 tasks:open-db))
3a20: 68 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 29 29 0a host-port-in))).
3a30: 09 09 3b 3b 20 09 20 20 20 20 20 3b 3b 20 28 70 ..;; . ;; (p
3a40: 72 69 6e 74 20 22 73 72 65 63 3a 20 22 20 73 72 rint "srec: " sr
3a50: 65 63 20 22 20 68 6f 73 74 2d 70 6f 72 74 2d 69 ec " host-port-i
3a60: 6e 3a 20 22 20 68 6f 73 74 2d 70 6f 72 74 2d 69 n: " host-port-i
3a70: 6e 29 0a 09 09 3b 3b 20 09 20 20 20 20 20 28 69 n)...;; . (i
3a80: 66 20 73 72 65 63 0a 09 09 3b 3b 20 09 09 20 28 f srec...;; .. (
3a90: 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 conc (vector-ref
3aa0: 20 73 72 65 63 20 33 29 20 22 3a 22 20 28 76 65 srec 3) ":" (ve
3ab0: 63 74 6f 72 2d 72 65 66 20 73 72 65 63 20 34 29 ctor-ref srec 4)
3ac0: 29 0a 09 09 3b 3b 20 09 09 20 28 63 6f 6e 63 20 )...;; .. (conc
3ad0: 22 6e 6f 20 73 75 63 68 20 73 65 72 76 65 72 2d "no such server-
3ae0: 69 64 20 22 20 68 6f 73 74 2d 70 6f 72 74 2d 69 id " host-port-i
3af0: 6e 29 29 29 0a 09 09 20 20 20 20 20 20 20 68 6f n)))... ho
3b00: 73 74 2d 70 6f 72 74 2d 69 6e 29 29 29 20 3b 3b st-port-in))) ;;
3b10: 20 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 68 ). (let* ((h
3b20: 6f 73 74 2d 70 6f 72 74 20 28 69 66 20 68 6f 73 ost-port (if hos
3b30: 74 3a 70 6f 72 74 0a 09 09 09 20 20 28 6c 65 74 t:port.... (let
3b40: 20 28 28 73 6c 73 74 20 28 73 74 72 69 6e 67 2d ((slst (string-
3b50: 73 70 6c 69 74 20 20 20 68 6f 73 74 3a 70 6f 72 split host:por
3b60: 74 20 22 3a 22 29 29 29 0a 09 09 09 20 20 20 20 t ":")))....
3b70: 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 (if (eq? (length
3b80: 20 73 6c 73 74 29 20 32 29 0a 09 09 09 09 28 6c slst) 2).....(l
3b90: 69 73 74 20 28 63 61 72 20 73 6c 73 74 29 28 73 ist (car slst)(s
3ba0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 tring->number (c
3bb0: 61 64 72 20 73 6c 73 74 29 29 29 0a 09 09 09 09 adr slst))).....
3bc0: 23 66 29 29 0a 09 09 09 20 20 23 66 29 29 29 0a #f)).... #f))).
3bd0: 3b 3b 09 20 20 20 28 74 6f 70 70 61 74 68 20 20 ;;. (toppath
3be0: 20 20 20 20 20 28 6c 61 75 6e 63 68 3a 73 65 74 (launch:set
3bf0: 75 70 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 up))). ;; (
3c00: 70 72 69 6e 74 20 22 68 6f 73 74 2d 70 6f 72 74 print "host-port
3c10: 3d 22 20 68 6f 73 74 2d 70 6f 72 74 29 0a 20 20 =" host-port).
3c20: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 68 6f 73 (if (not hos
3c30: 74 2d 70 6f 72 74 29 0a 09 20 20 28 62 65 67 69 t-port).. (begi
3c40: 6e 0a 09 20 20 20 20 28 69 66 20 68 6f 73 74 2d n.. (if host-
3c50: 70 6f 72 74 2d 69 6e 0a 09 09 28 64 65 62 75 67 port-in...(debug
3c60: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
3c70: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 45 52 t-log-port* "ER
3c80: 52 4f 52 3a 20 62 61 64 20 68 6f 73 74 3a 70 6f ROR: bad host:po
3c90: 72 74 22 29 29 0a 09 20 20 20 20 28 69 66 20 64 rt")).. (if d
3ca0: 6f 2d 65 78 69 74 20 28 65 78 69 74 20 31 29 29 o-exit (exit 1))
3cb0: 0a 09 20 20 20 20 23 66 29 0a 09 20 20 28 6c 65 .. #f).. (le
3cc0: 74 2a 20 28 28 69 66 61 63 65 20 20 20 20 20 20 t* ((iface
3cd0: 28 63 61 72 20 68 6f 73 74 2d 70 6f 72 74 29 29 (car host-port))
3ce0: 0a 09 09 20 28 70 6f 72 74 20 20 20 20 20 20 20 ... (port
3cf0: 28 63 61 64 72 20 68 6f 73 74 2d 70 6f 72 74 29 (cadr host-port)
3d00: 29 0a 09 09 20 28 73 65 72 76 65 72 2d 64 61 74 )... (server-dat
3d10: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
3d20: 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 :client-connect
3d30: 69 66 61 63 65 20 70 6f 72 74 29 29 0a 09 09 20 iface port))...
3d40: 28 6c 6f 67 69 6e 2d 72 65 73 20 20 28 72 6d 74 (login-res (rmt
3d50: 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 :login-no-auto-c
3d60: 6c 69 65 6e 74 2d 73 65 74 75 70 20 73 65 72 76 lient-setup serv
3d70: 65 72 2d 64 61 74 29 29 29 0a 09 20 20 20 20 28 er-dat))).. (
3d80: 69 66 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 6c if (and (list? l
3d90: 6f 67 69 6e 2d 72 65 73 29 0a 09 09 20 20 20 20 ogin-res)...
3da0: 20 28 63 61 72 20 6c 6f 67 69 6e 2d 72 65 73 29 (car login-res)
3db0: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 3b )...(begin... ;
3dc0: 3b 20 28 70 72 69 6e 74 20 22 4c 4f 47 49 4e 5f ; (print "LOGIN_
3dd0: 4f 4b 22 29 0a 09 09 20 20 28 69 66 20 64 6f 2d OK")... (if do-
3de0: 65 78 69 74 20 28 65 78 69 74 20 30 29 29 0a 09 exit (exit 0))..
3df0: 09 20 20 23 74 29 0a 09 09 28 62 65 67 69 6e 0a . #t)...(begin.
3e00: 09 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 4c .. ;; (print "L
3e10: 4f 47 49 4e 5f 46 41 49 4c 45 44 22 29 0a 09 09 OGIN_FAILED")...
3e20: 20 20 28 69 66 20 64 6f 2d 65 78 69 74 20 28 65 (if do-exit (e
3e30: 78 69 74 20 31 29 29 0a 09 09 20 20 23 66 29 29 xit 1))... #f))
3e40: 29 29 29 29 29 0a 0a 3b 3b 20 72 75 6e 20 70 69 )))))..;; run pi
3e50: 6e 67 20 69 6e 20 73 65 70 61 72 61 74 65 20 70 ng in separate p
3e60: 72 6f 63 65 73 73 2c 20 73 61 66 65 73 74 20 77 rocess, safest w
3e70: 61 79 20 69 6e 20 73 6f 6d 65 20 63 61 73 65 73 ay in some cases
3e80: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 .;;.(define (ser
3e90: 76 65 72 3a 70 69 6e 67 2d 73 65 72 76 65 72 20 ver:ping-server
3ea0: 69 66 61 63 65 70 6f 72 74 29 0a 20 20 28 77 69 ifaceport). (wi
3eb0: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
3ec0: 70 65 20 0a 20 20 20 28 63 6f 6e 63 20 28 63 6f pe . (conc (co
3ed0: 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 mmon:get-megates
3ee0: 74 2d 65 78 65 29 20 22 20 2d 70 69 6e 67 20 22 t-exe) " -ping "
3ef0: 20 69 66 61 63 65 70 6f 72 74 29 0a 20 20 20 28 ifaceport). (
3f00: 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 28 lambda (). (
3f10: 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 let loop ((inl (
3f20: 72 65 61 64 2d 6c 69 6e 65 29 29 0a 09 09 28 72 read-line))...(r
3f30: 65 73 20 22 4e 4f 52 45 50 4c 59 22 29 29 0a 20 es "NOREPLY")).
3f40: 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f (if (eof-o
3f50: 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 20 20 20 bject? inl)..
3f60: 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 (case (string->s
3f70: 79 6d 62 6f 6c 20 72 65 73 29 0a 09 20 20 20 20 ymbol res)..
3f80: 20 28 28 4e 4f 52 45 50 4c 59 29 20 20 23 66 29 ((NOREPLY) #f)
3f90: 0a 09 20 20 20 20 20 28 28 4c 4f 47 49 4e 5f 4f .. ((LOGIN_O
3fa0: 4b 29 20 23 74 29 0a 09 20 20 20 20 20 28 65 6c K) #t).. (el
3fb0: 73 65 20 20 20 20 20 20 20 23 66 29 29 0a 09 20 se #f))..
3fc0: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li
3fd0: 6e 65 29 20 69 6e 6c 29 29 29 29 29 29 0a 0a 3b ne) inl))))))..;
3fe0: 3b 20 4e 4f 54 20 55 53 45 44 20 28 77 65 6c 6c ; NOT USED (well
3ff0: 2c 20 6f 6b 2c 20 72 65 66 65 72 65 6e 63 65 20 , ok, reference
4000: 69 6e 20 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 in rpc-transport
4010: 20 62 75 74 20 6f 74 68 65 72 77 69 73 65 20 6e but otherwise n
4020: 6f 74 20 75 73 65 64 29 2e 0a 3b 3b 0a 28 64 65 ot used)..;;.(de
4030: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6c 6f 67 fine (server:log
4040: 69 6e 20 74 6f 70 70 61 74 68 29 0a 20 20 28 6c in toppath). (l
4050: 61 6d 62 64 61 20 28 74 6f 70 70 61 74 68 29 0a ambda (toppath).
4060: 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 (set! *db-la
4070: 73 74 2d 61 63 63 65 73 73 2a 20 28 63 75 72 72 st-access* (curr
4080: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b 3b ent-seconds)) ;;
4090: 20 6d 69 67 68 74 20 6e 6f 74 20 62 65 20 6e 65 might not be ne
40a0: 65 64 65 64 2e 0a 20 20 20 20 28 69 66 20 28 65 eded.. (if (e
40b0: 71 75 61 6c 3f 20 2a 74 6f 70 70 61 74 68 2a 20 qual? *toppath*
40c0: 74 6f 70 70 61 74 68 29 0a 09 23 74 0a 09 23 66 toppath)..#t..#f
40d0: 29 29 29 0a 0a 3b 3b 20 74 69 6d 65 6f 75 74 20 )))..;; timeout
40e0: 69 73 20 68 6d 73 20 73 74 72 69 6e 67 3a 20 31 is hms string: 1
40f0: 68 20 35 6d 20 33 73 2c 20 64 65 66 61 75 6c 74 h 5m 3s, default
4100: 20 69 73 20 31 20 6d 69 6e 75 74 65 0a 3b 3b 0a is 1 minute.;;.
4110: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
4120: 65 78 70 69 72 61 74 69 6f 6e 2d 74 69 6d 65 6f expiration-timeo
4130: 75 74 29 0a 20 20 28 6c 65 74 20 28 28 74 6d 6f ut). (let ((tmo
4140: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
4150: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
4160: 72 76 65 72 22 20 22 74 69 6d 65 6f 75 74 22 29 rver" "timeout")
4170: 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 )). (if (and
4180: 28 73 74 72 69 6e 67 3f 20 74 6d 6f 29 0a 09 20 (string? tmo)..
4190: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d (common:hms-
41a0: 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 string->seconds
41b0: 74 6d 6f 29 29 20 3b 3b 20 42 55 47 3a 20 68 6d tmo)) ;; BUG: hm
41c0: 73 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 s-string->second
41d0: 73 20 69 73 20 62 72 6f 6b 65 6e 2c 20 69 66 20 s is broken, if
41e0: 67 69 76 65 6e 20 22 31 30 22 20 72 65 74 75 72 given "10" retur
41f0: 6e 73 20 30 2e 20 41 6c 73 6f 2c 20 69 74 20 64 ns 0. Also, it d
4200: 6f 65 73 6e 27 74 20 62 65 6c 6f 6e 67 20 69 6e oesn't belong in
4210: 20 74 68 69 73 20 6c 6f 67 69 63 20 75 6e 6c 65 this logic unle
4220: 73 73 20 74 68 65 20 73 74 72 69 6e 67 2d 3e 6e ss the string->n
4230: 75 6d 62 65 72 20 69 73 20 63 68 61 6e 67 65 64 umber is changed
4240: 20 62 65 6c 6f 77 0a 20 20 20 20 20 20 20 20 28 below. (
4250: 2a 20 33 36 30 30 20 28 73 74 72 69 6e 67 2d 3e * 3600 (string->
4260: 6e 75 6d 62 65 72 20 74 6d 6f 29 29 0a 09 36 30 number tmo))..60
4270: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
4280: 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 rver:get-best-gu
4290: 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 ess-address host
42a0: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 name). (let ((r
42b0: 65 73 20 23 66 29 29 0a 20 20 20 20 28 66 6f 72 es #f)). (for
42c0: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
42d0: 62 64 61 20 28 61 64 72 29 0a 20 20 20 20 20 20 bda (adr).
42e0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 (if (not (eq? (
42f0: 75 38 76 65 63 74 6f 72 2d 72 65 66 20 61 64 72 u8vector-ref adr
4300: 20 30 29 20 31 32 37 29 29 0a 09 20 20 20 28 73 0) 127)).. (s
4310: 65 74 21 20 72 65 73 20 61 64 72 29 29 29 0a 20 et! res adr))).
4320: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
4330: 73 20 63 61 6e 20 66 61 69 6c 20 77 68 65 6e 20 s can fail when
4340: 74 68 65 72 65 20 69 73 20 6e 6f 20 6d 65 6e 74 there is no ment
4350: 69 6f 6e 20 6f 66 20 74 68 65 20 68 6f 73 74 20 ion of the host
4360: 69 6e 20 2f 65 74 63 2f 68 6f 73 74 73 2e 20 46 in /etc/hosts. F
4370: 49 58 4d 45 0a 20 20 20 20 20 28 76 65 63 74 6f IXME. (vecto
4380: 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 69 6e 66 r->list (hostinf
4390: 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 o-addresses (hos
43a0: 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 tname->hostinfo
43b0: 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 20 hostname)))).
43c0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
43d0: 65 72 73 65 20 0a 20 20 20 20 20 28 6d 61 70 20 erse . (map
43e0: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 0a 09 number->string..
43f0: 20 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 (u8vector->lis
4400: 74 0a 09 20 20 20 28 69 66 20 72 65 73 20 72 65 t.. (if res re
4410: 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 s (hostname->ip
4420: 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 22 2e 22 hostname)))) "."
4430: 29 29 29 0a 0a 3b 3b 20 6d 6f 76 69 6e 67 20 74 )))..;; moving t
4440: 68 69 73 20 68 65 72 65 20 61 73 20 69 74 20 6e his here as it n
4450: 65 65 64 73 20 61 63 63 65 73 73 20 74 6f 20 64 eeds access to d
4460: 62 20 61 6e 64 20 63 61 6e 6e 6f 74 20 62 65 20 b and cannot be
4470: 69 6e 20 63 6f 6d 6d 6f 6e 2e 0a 3b 3b 0a 28 64 in common..;;.(d
4480: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 77 72 efine (server:wr
4490: 69 74 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 20 itable-watchdog
44a0: 64 62 73 74 72 75 63 74 29 0a 20 20 28 74 68 72 dbstruct). (thr
44b0: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 ead-sleep! 0.05)
44c0: 20 3b 3b 20 64 65 6c 61 79 20 66 6f 72 20 73 74 ;; delay for st
44d0: 61 72 74 75 70 0a 20 20 28 6c 65 74 20 28 28 6c artup. (let ((l
44e0: 65 67 61 63 79 2d 73 79 6e 63 20 20 28 63 6f 6d egacy-sync (com
44f0: 6d 6f 6e 3a 72 75 6e 2d 73 79 6e 63 3f 29 29 0a mon:run-sync?)).
4500: 20 20 20 20 20 20 20 20 28 73 79 6e 63 2d 73 74 (sync-st
4510: 61 6c 65 2d 73 65 63 6f 6e 64 73 20 28 63 6f 6e ale-seconds (con
4520: 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 figf:lookup-numb
4530: 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 er *configdat* "
4540: 73 65 72 76 65 72 22 20 22 73 79 6e 63 2d 73 74 server" "sync-st
4550: 61 6c 65 2d 73 65 63 6f 6e 64 73 22 20 64 65 66 ale-seconds" def
4560: 61 75 6c 74 3a 20 33 30 30 29 29 0a 09 28 64 65 ault: 300))..(de
4570: 62 75 67 2d 6d 6f 64 65 20 20 20 28 64 65 62 75 bug-mode (debu
4580: 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 29 g:debug-mode 1))
4590: 0a 09 28 6c 61 73 74 2d 74 69 6d 65 20 20 20 20 ..(last-time
45a0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
45b0: 29 29 0a 09 28 6e 6f 2d 73 79 6e 63 2d 64 62 20 ))..(no-sync-db
45c0: 20 20 28 64 62 3a 6f 70 65 6e 2d 6e 6f 2d 73 79 (db:open-no-sy
45d0: 6e 63 2d 64 62 29 29 0a 20 20 20 20 20 20 20 20 nc-db)).
45e0: 28 73 79 6e 63 2d 64 75 72 61 74 69 6f 6e 20 30 (sync-duration 0
45f0: 29 20 3b 3b 20 72 75 6e 20 74 69 6d 65 20 6f 66 ) ;; run time of
4600: 20 74 68 65 20 73 79 6e 63 20 69 6e 20 6d 69 6c the sync in mil
4610: 6c 69 73 65 63 6f 6e 64 73 0a 20 20 20 20 20 20 liseconds.
4620: 20 20 3b 3b 28 74 68 69 73 2d 77 64 2d 6e 75 6d ;;(this-wd-num
4630: 20 20 28 62 65 67 69 6e 20 28 6d 75 74 65 78 2d (begin (mutex-
4640: 6c 6f 63 6b 21 20 2a 77 64 6e 75 6d 2a 6d 75 74 lock! *wdnum*mut
4650: 65 78 29 20 28 6c 65 74 20 28 28 78 20 2a 77 64 ex) (let ((x *wd
4660: 6e 75 6d 2a 29 29 20 28 73 65 74 21 20 2a 77 64 num*)) (set! *wd
4670: 6e 75 6d 2a 20 28 61 64 64 31 20 2a 77 64 6e 75 num* (add1 *wdnu
4680: 6d 2a 29 29 20 28 6d 75 74 65 78 2d 75 6e 6c 6f m*)) (mutex-unlo
4690: 63 6b 21 20 2a 77 64 6e 75 6d 2a 6d 75 74 65 78 ck! *wdnum*mutex
46a0: 29 20 78 29 29 29 0a 20 20 20 20 20 20 20 20 29 ) x))). )
46b0: 0a 20 20 20 20 28 73 65 74 21 20 2a 6e 6f 2d 73 . (set! *no-s
46c0: 79 6e 63 2d 64 62 2a 20 6e 6f 2d 73 79 6e 63 2d ync-db* no-sync-
46d0: 64 62 29 20 3b 3b 20 6d 61 6b 65 20 74 68 65 20 db) ;; make the
46e0: 6e 6f 20 73 79 6e 63 20 64 62 20 61 76 61 69 6c no sync db avail
46f0: 61 62 6c 65 20 74 6f 20 61 70 69 20 63 61 6c 6c able to api call
4700: 73 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 s. (debug:pri
4710: 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 nt-info 2 *defau
4720: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 65 lt-log-port* "Pe
4730: 72 69 6f 64 69 63 20 73 79 6e 63 20 74 68 72 65 riodic sync thre
4740: 61 64 20 73 74 61 72 74 65 64 2e 22 29 0a 20 20 ad started.").
4750: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4760: 6e 66 6f 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 3 *default-l
4770: 6f 67 2d 70 6f 72 74 2a 20 22 77 61 74 63 68 64 og-port* "watchd
4780: 6f 67 20 73 74 61 72 74 69 6e 67 2e 20 6c 65 67 og starting. leg
4790: 61 63 79 2d 73 79 6e 63 20 69 73 20 22 20 6c 65 acy-sync is " le
47a0: 67 61 63 79 2d 73 79 6e 63 22 20 70 69 64 3d 22 gacy-sync" pid="
47b0: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
47c0: 2d 69 64 29 20 20 29 3b 3b 20 20 22 20 74 68 69 -id) );; " thi
47d0: 73 2d 77 64 2d 6e 75 6d 3d 22 74 68 69 73 2d 77 s-wd-num="this-w
47e0: 64 2d 6e 75 6d 29 0a 20 20 20 20 28 69 66 20 28 d-num). (if (
47f0: 61 6e 64 20 6c 65 67 61 63 79 2d 73 79 6e 63 20 and legacy-sync
4800: 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 (not *time-to-ex
4810: 69 74 2a 29 29 0a 09 28 6c 65 74 2a 20 28 3b 3b it*))..(let* (;;
4820: 28 64 62 73 74 72 75 63 74 20 28 64 62 3a 73 65 (dbstruct (db:se
4830: 74 75 70 29 29 0a 09 20 20 20 20 20 20 20 28 6d tup)).. (m
4840: 74 64 62 20 20 20 20 20 20 20 28 64 62 72 3a 64 tdb (dbr:d
4850: 62 73 74 72 75 63 74 2d 6d 74 64 62 20 64 62 73 bstruct-mtdb dbs
4860: 74 72 75 63 74 29 29 0a 09 20 20 20 20 20 20 20 truct))..
4870: 28 6d 74 70 61 74 68 20 20 20 20 20 28 64 62 3a (mtpath (db:
4880: 64 62 64 61 74 2d 67 65 74 2d 70 61 74 68 20 6d dbdat-get-path m
4890: 74 64 62 29 29 0a 09 20 20 20 20 20 20 20 28 74 tdb)).. (t
48a0: 6d 70 2d 61 72 65 61 20 20 20 28 63 6f 6d 6d 6f mp-area (commo
48b0: 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 n:get-db-tmp-are
48c0: 61 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 a)).. (sta
48d0: 72 74 2d 66 69 6c 65 20 28 63 6f 6e 63 20 74 6d rt-file (conc tm
48e0: 70 2d 61 72 65 61 20 22 2f 2e 73 74 61 72 74 2d p-area "/.start-
48f0: 73 79 6e 63 22 29 29 0a 09 20 20 20 20 20 20 20 sync"))..
4900: 28 65 6e 64 2d 66 69 6c 65 20 20 20 28 63 6f 6e (end-file (con
4910: 63 20 74 6d 70 2d 61 72 65 61 20 22 2f 2e 65 6e c tmp-area "/.en
4920: 64 2d 73 79 6e 63 22 29 29 29 0a 09 20 20 28 64 d-sync"))).. (d
4930: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4940: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
4950: 6f 72 74 2a 20 22 53 65 72 76 65 72 20 72 75 6e ort* "Server run
4960: 6e 69 6e 67 2c 20 70 65 72 69 6f 64 69 63 20 73 ning, periodic s
4970: 79 6e 63 20 73 74 61 72 74 65 64 2e 22 29 0a 09 ync started.")..
4980: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 09 (let loop ()..
4990: 20 20 20 20 3b 3b 20 73 79 6e 63 20 66 6f 72 20 ;; sync for
49a0: 66 69 6c 65 73 79 73 74 65 6d 20 6c 6f 63 61 6c filesystem local
49b0: 20 64 62 20 77 72 69 74 65 73 0a 09 20 20 20 20 db writes..
49c0: 3b 3b 0a 09 20 20 20 20 28 6d 75 74 65 78 2d 6c ;;.. (mutex-l
49d0: 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 ock! *db-multi-s
49e0: 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 ync-mutex*)..
49f0: 20 28 6c 65 74 2a 20 28 28 6e 65 65 64 2d 73 79 (let* ((need-sy
4a00: 6e 63 20 20 20 20 20 20 20 20 28 3e 3d 20 2a 64 nc (>= *d
4a10: 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 2a b-last-access* *
4a20: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 29 20 db-last-sync*))
4a30: 3b 3b 20 6e 6f 20 73 79 6e 63 20 73 69 6e 63 65 ;; no sync since
4a40: 20 6c 61 73 74 20 77 72 69 74 65 0a 09 09 20 20 last write...
4a50: 20 28 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 (sync-in-progre
4a60: 73 73 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 ss *db-sync-in-p
4a70: 72 6f 67 72 65 73 73 2a 29 0a 20 20 20 20 20 20 rogress*).
4a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 69 (mi
4a90: 6e 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 n-intersync-dela
4aa0: 79 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 y (configf:looku
4ab0: 70 2d 6e 75 6d 62 65 72 20 2a 63 6f 6e 66 69 67 p-number *config
4ac0: 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 6d dat* "server" "m
4ad0: 69 6e 69 6d 75 6d 2d 69 6e 74 65 72 73 79 6e 63 inimum-intersync
4ae0: 2d 64 65 6c 61 79 22 20 64 65 66 61 75 6c 74 3a -delay" default:
4af0: 20 35 29 29 0a 09 09 20 20 20 28 73 68 6f 75 6c 5))... (shoul
4b00: 64 2d 73 79 6e 63 20 20 20 20 20 20 28 61 6e 64 d-sync (and
4b10: 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 (not *time-to-e
4b20: 78 69 74 2a 29 0a 20 20 20 20 20 20 20 20 20 20 xit*).
4b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b50: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
4b60: 65 63 6f 6e 64 73 29 20 2a 64 62 2d 6c 61 73 74 econds) *db-last
4b70: 2d 73 79 6e 63 2a 29 20 6d 69 6e 2d 69 6e 74 65 -sync*) min-inte
4b80: 72 73 79 6e 63 2d 64 65 6c 61 79 29 29 29 20 3b rsync-delay))) ;
4b90: 3b 20 73 79 6e 63 20 65 76 65 72 79 20 66 69 76 ; sync every fiv
4ba0: 65 20 73 65 63 6f 6e 64 73 20 6d 69 6e 69 6d 75 e seconds minimu
4bb0: 6d 2c 20 64 65 70 72 65 63 61 74 65 64 20 6c 6f m, deprecated lo
4bc0: 67 69 63 2c 20 63 61 6e 20 70 72 6f 62 61 62 6c gic, can probabl
4bd0: 79 20 62 65 20 72 65 6d 6f 76 65 64 0a 09 09 20 y be removed...
4be0: 20 20 28 73 74 61 72 74 2d 74 69 6d 65 20 20 20 (start-time
4bf0: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (current-sec
4c00: 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 onds)).
4c10: 20 20 20 20 20 20 20 20 20 20 28 63 70 75 2d 6c (cpu-l
4c20: 6f 61 64 2d 61 64 6a 20 20 20 20 20 28 61 6c 69 oad-adj (ali
4c30: 73 74 2d 72 65 66 20 27 61 64 6a 2d 70 72 6f 63 st-ref 'adj-proc
4c40: 2d 6c 6f 61 64 20 28 63 6f 6d 6d 6f 6e 3a 67 65 -load (common:ge
4c50: 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 t-normalized-cpu
4c60: 2d 6c 6f 61 64 20 23 66 29 29 29 0a 09 09 20 20 -load #f)))...
4c70: 20 28 6d 74 2d 6d 6f 64 2d 74 69 6d 65 20 20 20 (mt-mod-time
4c80: 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 (file-modific
4c90: 61 74 69 6f 6e 2d 74 69 6d 65 20 6d 74 70 61 74 ation-time mtpat
4ca0: 68 29 29 0a 09 09 20 20 20 28 6c 61 73 74 2d 73 h))... (last-s
4cb0: 79 6e 63 2d 73 74 61 72 74 20 20 28 69 66 20 28 ync-start (if (
4cc0: 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
4cd0: 74 73 3f 20 73 74 61 72 74 2d 66 69 6c 65 29 0a ts? start-file).
4ce0: 09 09 09 09 09 20 28 66 69 6c 65 2d 6d 6f 64 69 ..... (file-modi
4cf0: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 74 fication-time st
4d00: 61 72 74 2d 66 69 6c 65 29 0a 09 09 09 09 09 20 art-file)......
4d10: 30 29 29 0a 09 09 20 20 20 28 6c 61 73 74 2d 73 0))... (last-s
4d20: 79 6e 63 2d 65 6e 64 20 20 20 20 28 69 66 20 28 ync-end (if (
4d30: 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
4d40: 74 73 3f 20 65 6e 64 2d 66 69 6c 65 29 0a 09 09 ts? end-file)...
4d50: 09 09 09 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 ... (file-modifi
4d60: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 65 6e 64 2d cation-time end-
4d70: 66 69 6c 65 29 0a 09 09 09 09 09 20 31 30 29 29 file)...... 10))
4d80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4d90: 20 20 20 20 28 73 79 6e 63 2d 70 65 72 69 6f 64 (sync-period
4da0: 20 20 20 20 20 20 28 2b 20 33 20 28 2a 20 63 70 (+ 3 (* cp
4db0: 75 2d 6c 6f 61 64 2d 61 64 6a 20 33 30 29 29 29 u-load-adj 30)))
4dc0: 20 3b 3b 20 61 73 20 61 64 6a 75 73 74 65 64 20 ;; as adjusted
4dd0: 6c 6f 61 64 20 69 6e 63 72 65 61 73 65 73 20 69 load increases i
4de0: 6e 63 72 65 61 73 65 20 74 68 65 20 73 79 6e 63 ncrease the sync
4df0: 20 70 65 72 69 6f 64 0a 09 09 20 20 20 28 72 65 period... (re
4e00: 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 20 20 28 cently-synced (
4e10: 61 6e 64 20 28 3c 20 28 2d 20 73 74 61 72 74 2d and (< (- start-
4e20: 74 69 6d 65 20 6d 74 2d 6d 6f 64 2d 74 69 6d 65 time mt-mod-time
4e30: 29 20 73 79 6e 63 2d 70 65 72 69 6f 64 29 20 3b ) sync-period) ;
4e40: 3b 20 6e 6f 74 20 75 73 65 66 75 6c 20 69 66 20 ; not useful if
4e50: 73 79 6e 63 20 64 69 64 6e 27 74 20 6d 6f 64 69 sync didn't modi
4e60: 66 79 20 6d 65 67 61 74 65 73 74 2e 64 62 21 0a fy megatest.db!.
4e70: 09 09 09 09 09 20 20 28 3c 20 6d 74 2d 6d 6f 64 ..... (< mt-mod
4e80: 2d 74 69 6d 65 20 6c 61 73 74 2d 73 79 6e 63 2d -time last-sync-
4e90: 73 74 61 72 74 29 29 29 0a 09 09 20 20 20 28 73 start)))... (s
4ea0: 79 6e 63 2d 64 6f 6e 65 20 20 20 20 20 20 20 20 ync-done
4eb0: 28 3c 3d 20 6c 61 73 74 2d 73 79 6e 63 2d 73 74 (<= last-sync-st
4ec0: 61 72 74 20 6c 61 73 74 2d 73 79 6e 63 2d 65 6e art last-sync-en
4ed0: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d)).
4ee0: 20 20 20 20 20 20 20 28 73 79 6e 63 2d 73 74 61 (sync-sta
4ef0: 6c 65 20 20 20 20 20 20 20 28 3e 20 73 74 61 72 le (> star
4f00: 74 2d 74 69 6d 65 20 28 2b 20 6c 61 73 74 2d 73 t-time (+ last-s
4f10: 79 6e 63 2d 73 74 61 72 74 20 73 79 6e 63 2d 73 ync-start sync-s
4f20: 74 61 6c 65 2d 73 65 63 6f 6e 64 73 29 29 29 0a tale-seconds))).
4f30: 09 09 20 20 20 28 77 69 6c 6c 2d 73 79 6e 63 20 .. (will-sync
4f40: 20 20 20 20 20 20 20 28 61 6e 64 20 28 6e 6f 74 (and (not
4f50: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 *time-to-exit*)
4f60: 20 20 20 20 20 20 20 3b 3b 20 64 6f 20 6e 6f 74 ;; do not
4f70: 20 73 74 61 72 74 20 61 20 73 79 6e 63 20 69 66 start a sync if
4f80: 20 77 65 20 61 72 65 20 69 6e 20 74 68 65 20 70 we are in the p
4f90: 72 6f 63 65 73 73 20 6f 66 20 65 78 69 74 69 6e rocess of exitin
4fa0: 67 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 g.
4fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4fc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 (or
4fd0: 6e 65 65 64 2d 73 79 6e 63 20 73 68 6f 75 6c 64 need-sync should
4fe0: 2d 73 79 6e 63 29 0a 09 09 09 09 09 20 20 28 6f -sync)...... (o
4ff0: 72 20 73 79 6e 63 2d 64 6f 6e 65 20 73 79 6e 63 r sync-done sync
5000: 2d 73 74 61 6c 65 29 0a 09 09 09 09 09 20 20 28 -stale)...... (
5010: 6e 6f 74 20 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 not sync-in-prog
5020: 72 65 73 73 29 0a 09 09 09 09 09 20 20 28 6e 6f ress)...... (no
5030: 74 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 t recently-synce
5040: 64 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 d)))).
5050: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5060: 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c -info 13 *defaul
5070: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 44 20 t-log-port* "WD
5080: 77 72 69 74 61 62 6c 65 2d 77 61 74 63 68 64 6f writable-watchdo
5090: 67 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 2e 20 20 g top of loop.
50a0: 6e 65 65 64 2d 73 79 6e 63 3d 22 6e 65 65 64 2d need-sync="need-
50b0: 73 79 6e 63 22 20 73 79 6e 63 2d 69 6e 2d 70 72 sync" sync-in-pr
50c0: 6f 67 72 65 73 73 3d 22 20 73 79 6e 63 2d 69 6e ogress=" sync-in
50d0: 2d 70 72 6f 67 72 65 73 73 0a 09 09 09 09 22 20 -progress....."
50e0: 73 68 6f 75 6c 64 2d 73 79 6e 63 3d 22 73 68 6f should-sync="sho
50f0: 75 6c 64 2d 73 79 6e 63 22 20 73 74 61 72 74 2d uld-sync" start-
5100: 74 69 6d 65 3d 22 73 74 61 72 74 2d 74 69 6d 65 time="start-time
5110: 22 20 6d 74 2d 6d 6f 64 2d 74 69 6d 65 3d 22 6d " mt-mod-time="m
5120: 74 2d 6d 6f 64 2d 74 69 6d 65 22 20 72 65 63 65 t-mod-time" rece
5130: 6e 74 6c 79 2d 73 79 6e 63 65 64 3d 22 72 65 63 ntly-synced="rec
5140: 65 6e 74 6c 79 2d 73 79 6e 63 65 64 22 20 77 69 ently-synced" wi
5150: 6c 6c 2d 73 79 6e 63 3d 22 77 69 6c 6c 2d 73 79 ll-sync="will-sy
5160: 6e 63 0a 09 09 09 09 22 20 73 79 6e 63 2d 64 6f nc....." sync-do
5170: 6e 65 3d 22 20 73 79 6e 63 2d 64 6f 6e 65 20 22 ne=" sync-done "
5180: 20 73 79 6e 63 2d 70 65 72 69 6f 64 3d 22 20 73 sync-period=" s
5190: 79 6e 63 2d 70 65 72 69 6f 64 29 0a 20 20 20 20 ync-period).
51a0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
51b0: 6e 64 20 28 3e 20 73 79 6e 63 2d 70 65 72 69 6f nd (> sync-perio
51c0: 64 20 35 29 0a 20 20 20 20 20 20 20 20 20 20 20 d 5).
51d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d (com
51e0: 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 mon:low-noise-pr
51f0: 69 6e 74 20 33 30 20 22 73 79 6e 63 2d 70 65 72 int 30 "sync-per
5200: 69 6f 64 22 29 29 0a 20 20 20 20 20 20 20 20 20 iod")).
5210: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
5220: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5230: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5240: 22 49 6e 63 72 65 61 73 65 64 20 73 79 6e 63 20 "Increased sync
5250: 70 65 72 69 6f 64 20 64 75 65 20 74 6f 20 6c 6f period due to lo
5260: 6e 67 20 73 79 6e 63 20 74 69 6d 65 73 2c 20 73 ng sync times, s
5270: 79 6e 63 20 74 6f 6f 6b 3a 20 22 20 73 79 6e 63 ync took: " sync
5280: 2d 70 65 72 69 6f 64 20 22 20 73 65 63 6f 6e 64 -period " second
5290: 73 2e 22 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 s.")).. ;;
52a0: 28 69 66 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e (if recently-syn
52b0: 63 65 64 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ced (debug:print
52c0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
52d0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 6b 69 70 -log-port* "Skip
52e0: 70 69 6e 67 20 73 79 6e 63 20 64 75 65 20 74 6f ping sync due to
52f0: 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 recently-synced
5300: 20 66 6c 61 67 3d 22 20 72 65 63 65 6e 74 6c 79 flag=" recently
5310: 2d 73 79 6e 63 65 64 29 29 0a 09 20 20 20 20 20 -synced))..
5320: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
5330: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5340: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 65 65 64 -log-port* "need
5350: 2d 73 79 6e 63 3a 20 22 20 6e 65 65 64 2d 73 79 -sync: " need-sy
5360: 6e 63 20 22 20 73 79 6e 63 2d 69 6e 2d 70 72 6f nc " sync-in-pro
5370: 67 72 65 73 73 3a 20 22 20 73 79 6e 63 2d 69 6e gress: " sync-in
5380: 2d 70 72 6f 67 72 65 73 73 20 22 20 73 68 6f 75 -progress " shou
5390: 6c 64 2d 73 79 6e 63 3a 20 22 20 73 68 6f 75 6c ld-sync: " shoul
53a0: 64 2d 73 79 6e 63 20 22 20 77 69 6c 6c 2d 73 79 d-sync " will-sy
53b0: 6e 63 3a 20 22 20 77 69 6c 6c 2d 73 79 6e 63 29 nc: " will-sync)
53c0: 0a 09 20 20 20 20 20 20 28 69 66 20 77 69 6c 6c .. (if will
53d0: 2d 73 79 6e 63 20 28 73 65 74 21 20 2a 64 62 2d -sync (set! *db-
53e0: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
53f0: 2a 20 23 74 29 29 0a 09 20 20 20 20 20 20 28 6d * #t)).. (m
5400: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 utex-unlock! *db
5410: 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 -multi-sync-mute
5420: 78 2a 29 0a 09 20 20 20 20 20 20 28 69 66 20 77 x*).. (if w
5430: 69 6c 6c 2d 73 79 6e 63 0a 20 20 20 20 20 20 20 ill-sync.
5440: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
5450: 28 3b 3b 20 28 6d 61 78 2d 73 79 6e 63 2d 64 75 (;; (max-sync-du
5460: 72 61 74 69 6f 6e 20 20 28 63 6f 6e 66 69 67 66 ration (configf
5470: 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 65 72 20 2a :lookup-number *
5480: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 configdat* "serv
5490: 65 72 22 20 22 6d 61 78 2d 73 79 6e 63 2d 64 75 er" "max-sync-du
54a0: 72 61 74 69 6f 6e 22 29 29 20 3b 3b 20 4b 45 45 ration")) ;; KEE
54b0: 50 49 4e 47 20 54 48 49 53 20 41 56 41 49 4c 41 PING THIS AVAILA
54c0: 42 4c 45 20 42 55 54 20 53 48 4f 55 4c 44 20 4e BLE BUT SHOULD N
54d0: 4f 54 20 55 53 45 2c 20 49 27 4d 20 50 52 45 54 OT USE, I'M PRET
54e0: 54 59 20 53 55 52 45 20 49 54 20 44 4f 45 53 20 TY SURE IT DOES
54f0: 4e 4f 54 20 57 4f 52 4b 21 0a 20 20 20 20 20 20 NOT WORK!.
5500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5510: 20 20 28 73 79 6e 63 2d 73 74 61 72 74 20 20 20 (sync-start
5520: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 6d (current-m
5530: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 09 illiseconds)))..
5540: 09 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 . (with-outpu
5550: 74 2d 74 6f 2d 66 69 6c 65 20 73 74 61 72 74 2d t-to-file start-
5560: 66 69 6c 65 20 28 6c 61 6d 62 64 61 20 28 29 28 file (lambda ()(
5570: 70 72 69 6e 74 20 28 63 75 72 72 65 6e 74 2d 70 print (current-p
5580: 72 6f 63 65 73 73 2d 69 64 29 29 29 29 0a 09 09 rocess-id))))...
5590: 20 20 20 20 0a 09 09 20 20 20 20 3b 3b 20 70 75 ... ;; pu
55a0: 74 20 6c 6f 63 6b 20 68 65 72 65 0a 09 09 20 20 t lock here...
55b0: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
55c0: 20 20 20 20 20 20 20 3b 3b 20 28 69 66 20 28 6f ;; (if (o
55d0: 72 20 28 6e 6f 74 20 6d 61 78 2d 73 79 6e 63 2d r (not max-sync-
55e0: 64 75 72 61 74 69 6f 6e 29 0a 20 20 20 20 20 20 duration).
55f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
5600: 20 20 20 20 20 20 20 20 28 3c 20 73 79 6e 63 2d (< sync-
5610: 64 75 72 61 74 69 6f 6e 20 6d 61 78 2d 73 79 6e duration max-syn
5620: 63 2d 64 75 72 61 74 69 6f 6e 29 29 20 3b 3b 20 c-duration)) ;;
5630: 4e 4f 54 45 3a 20 64 62 3a 73 79 6e 63 2d 74 6f NOTE: db:sync-to
5640: 2d 6d 65 67 61 74 65 73 74 2e 64 62 20 6b 65 65 -megatest.db kee
5650: 70 73 20 74 72 61 63 6b 20 6f 66 20 74 69 6d 65 ps track of time
5660: 20 6f 66 20 6c 61 73 74 20 73 79 6e 63 20 61 6e of last sync an
5670: 64 20 73 79 6e 63 73 20 69 6e 63 72 65 6d 65 6e d syncs incremen
5680: 74 61 6c 6c 79 0a 20 20 20 20 20 20 20 20 20 20 tally.
5690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
56a0: 65 74 20 28 28 72 65 73 20 20 20 20 20 20 20 20 et ((res
56b0: 28 64 62 3a 73 79 6e 63 2d 74 6f 2d 6d 65 67 61 (db:sync-to-mega
56c0: 74 65 73 74 2e 64 62 20 64 62 73 74 72 75 63 74 test.db dbstruct
56d0: 20 6e 6f 2d 73 79 6e 63 2d 64 62 3a 20 6e 6f 2d no-sync-db: no-
56e0: 73 79 6e 63 2d 64 62 29 29 29 20 3b 3b 20 64 69 sync-db))) ;; di
56f0: 64 20 77 65 20 73 79 6e 63 20 61 6e 79 20 64 61 d we sync any da
5700: 74 61 3f 20 49 66 20 73 6f 20 6e 65 65 64 20 74 ta? If so need t
5710: 6f 20 73 65 74 20 74 68 65 20 64 62 20 74 6f 75 o set the db tou
5720: 63 68 65 64 20 66 6c 61 67 20 74 6f 20 6b 65 65 ched flag to kee
5730: 70 20 74 68 65 20 73 65 72 76 65 72 20 61 6c 69 p the server ali
5740: 76 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ve.
5750: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
5760: 74 21 20 73 79 6e 63 2d 64 75 72 61 74 69 6f 6e t! sync-duration
5770: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c (- (current-mil
5780: 6c 69 73 65 63 6f 6e 64 73 29 20 73 79 6e 63 2d liseconds) sync-
5790: 73 74 61 72 74 29 29 0a 20 20 20 20 20 20 20 20 start)).
57a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57b0: 20 20 28 69 66 20 28 3e 20 72 65 73 20 30 29 20 (if (> res 0)
57c0: 3b 3b 20 73 6f 6d 65 20 72 65 63 6f 72 64 73 20 ;; some records
57d0: 77 65 72 65 20 74 72 61 6e 73 66 65 72 72 65 64 were transferred
57e0: 2c 20 6b 65 65 70 20 74 68 65 20 64 62 20 61 6c , keep the db al
57f0: 69 76 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ive.
5800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5810: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
5820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5830: 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d (mutex-
5840: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat
5850: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 -mutex*).
5860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5870: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 2a (set! *
5880: 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 db-last-access*
5890: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
58a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
58b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58c0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
58d0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
58e0: 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ex*).
58f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5900: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
5910: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5920: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 79 6e t-log-port* "syn
5930: 63 20 63 61 6c 6c 65 64 2c 20 22 20 72 65 73 20 c called, " res
5940: 22 20 72 65 63 6f 72 64 73 20 74 72 61 6e 73 66 " records transf
5950: 65 72 72 65 64 2e 22 29 29 0a 20 20 20 20 20 20 erred.")).
5960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5970: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
5980: 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 rint-info 2 *def
5990: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
59a0: 73 79 6e 63 20 63 61 6c 6c 65 64 20 62 75 74 20 sync called but
59b0: 7a 65 72 6f 20 72 65 63 6f 72 64 73 20 74 72 61 zero records tra
59c0: 6e 73 66 65 72 72 65 64 22 29 29 29 29 29 0a 3b nsferred"))))).;
59d0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
59e0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 54 4f 44 ;; TOD
59f0: 4f 3a 20 66 61 63 74 6f 72 20 74 68 69 73 20 6e O: factor this n
5a00: 65 78 74 20 72 6f 75 74 69 6e 65 20 6f 75 74 20 ext routine out
5a10: 69 6e 74 6f 20 61 20 66 75 6e 63 74 69 6f 6e 0a into a function.
5a20: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5a30: 20 20 20 20 20 20 20 20 20 20 20 28 77 69 74 68 (with
5a40: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
5a50: 20 3b 3b 20 74 68 69 73 20 73 68 6f 75 6c 64 20 ;; this should
5a60: 6e 6f 74 20 62 6c 6f 63 6b 20 6f 74 68 65 72 20 not block other
5a70: 74 68 72 65 61 64 73 20 62 75 74 20 6e 65 65 64 threads but need
5a80: 20 74 6f 20 76 65 72 69 66 79 20 74 68 69 73 0a to verify this.
5a90: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5aa0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
5ab0: 63 20 22 6d 65 67 61 74 65 73 74 20 2d 73 79 6e c "megatest -syn
5ac0: 63 2d 74 6f 2d 6d 65 67 61 74 65 73 74 2e 64 62 c-to-megatest.db
5ad0: 20 2d 6d 20 74 65 73 74 73 75 69 74 65 3a 22 20 -m testsuite:"
5ae0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 (common:get-area
5af0: 2d 6e 61 6d 65 29 20 22 3a 22 20 2a 74 6f 70 70 -name) ":" *topp
5b00: 61 74 68 2a 29 0a 3b 3b 20 20 20 20 20 20 20 20 ath*).;;
5b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b20: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 20 (lambda ().;;
5b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b40: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
5b50: 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 loop ((inl (read
5b60: 2d 6c 69 6e 65 29 29 0a 3b 3b 20 20 20 20 20 20 -line)).;;
5b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b90: 20 28 72 65 73 20 23 66 29 29 0a 3b 3b 20 20 20 (res #f)).;;
5ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bb0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
5bc0: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 eof-object? inl)
5bd0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
5be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bf0: 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 20 (begin.;;
5c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c20: 20 20 28 73 65 74 21 20 73 79 6e 63 2d 64 75 72 (set! sync-dur
5c30: 61 74 69 6f 6e 20 28 2d 20 28 63 75 72 72 65 6e ation (- (curren
5c40: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 t-milliseconds)
5c50: 73 79 6e 63 2d 73 74 61 72 74 29 29 0a 3b 3b 20 sync-start)).;;
5c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c80: 20 20 20 28 63 6f 6e 64 0a 3b 3b 20 20 20 20 20 (cond.;;
5c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5cb0: 28 28 6e 6f 74 20 72 65 73 29 0a 3b 3b 20 20 20 ((not res).;;
5cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ce0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5cf0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5d00: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 73 79 6e ort* "ERROR: syn
5d10: 63 20 66 72 6f 6d 20 2f 74 6d 70 20 64 62 20 74 c from /tmp db t
5d20: 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 20 61 70 o megatest.db ap
5d30: 70 65 61 72 73 20 74 6f 20 68 61 76 65 20 66 61 pears to have fa
5d40: 69 6c 65 64 2e 20 52 65 63 6f 6d 6d 65 6e 64 65 iled. Recommende
5d50: 64 20 74 68 61 74 20 79 6f 75 20 73 74 6f 70 20 d that you stop
5d60: 79 6f 75 72 20 72 75 6e 73 20 61 6e 64 20 72 75 your runs and ru
5d70: 6e 20 5c 22 6d 65 67 61 74 65 73 74 20 2d 63 6c n \"megatest -cl
5d80: 65 61 6e 75 70 2d 64 62 5c 22 22 29 29 0a 3b 3b eanup-db\"")).;;
5d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5db0: 20 20 20 20 20 28 28 3e 20 72 65 73 20 30 29 0a ((> res 0).
5dc0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5de0: 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c (mutex-l
5df0: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
5e00: 6d 75 74 65 78 2a 29 0a 3b 3b 20 20 20 20 20 20 mutex*).;;
5e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e30: 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 61 (set! *db-last-a
5e40: 63 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 2d ccess* (current-
5e50: 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 20 20 20 20 seconds)).;;
5e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e80: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
5e90: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
5ea0: 78 2a 29 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 x*)))).;;
5eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ec0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
5ed0: 28 28 6e 75 6d 2d 73 79 6e 63 65 64 20 28 6c 65 ((num-synced (le
5ee0: 74 20 28 28 6d 61 74 63 68 65 73 20 28 73 74 72 t ((matches (str
5ef0: 69 6e 67 2d 6d 61 74 63 68 20 22 5e 53 79 6e 63 ing-match "^Sync
5f00: 65 64 20 28 5c 5c 64 2b 29 2e 2a 24 22 20 69 6e ed (\\d+).*$" in
5f10: 6c 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 l))).;;
5f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
5f50: 20 6d 61 74 63 68 65 73 0a 3b 3b 20 20 20 20 20 matches.;;
5f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f90: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
5fa0: 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 mber (cadr match
5fb0: 65 73 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 es)).;;
5fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ff0: 20 23 66 29 29 29 29 0a 3b 3b 20 20 20 20 20 20 #f)))).;;
6000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
6020: 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 0a oop (read-line).
6030: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
6040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6050: 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 (or
6060: 6e 75 6d 2d 73 79 6e 63 65 64 20 72 65 73 29 29 num-synced res))
6070: 29 29 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 ))))))))..
6080: 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 0a 09 09 (if will-sync...
6090: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 (begin... (
60a0: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
60b0: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
60c0: 2a 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 2a *)... (set! *
60d0: 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 db-sync-in-progr
60e0: 65 73 73 2a 20 23 66 29 0a 09 09 20 20 20 20 28 ess* #f)... (
60f0: 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 73 79 set! *db-last-sy
6100: 6e 63 2a 20 73 74 61 72 74 2d 74 69 6d 65 29 0a nc* start-time).
6110: 09 09 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 .. (with-outp
6120: 75 74 2d 74 6f 2d 66 69 6c 65 20 65 6e 64 2d 66 ut-to-file end-f
6130: 69 6c 65 20 28 6c 61 6d 62 64 61 20 28 29 28 70 ile (lambda ()(p
6140: 72 69 6e 74 20 28 63 75 72 72 65 6e 74 2d 70 72 rint (current-pr
6150: 6f 63 65 73 73 2d 69 64 29 29 29 29 0a 0a 09 09 ocess-id))))....
6160: 20 20 20 20 3b 3b 20 72 65 6c 65 61 73 65 20 6c ;; release l
6170: 6f 63 6b 20 68 65 72 65 0a 0a 09 09 20 20 20 20 ock here....
6180: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
6190: 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 db-multi-sync-mu
61a0: 74 65 78 2a 29 29 29 0a 09 20 20 20 20 20 20 28 tex*))).. (
61b0: 69 66 20 28 61 6e 64 20 64 65 62 75 67 2d 6d 6f if (and debug-mo
61c0: 64 65 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 de... (> (
61d0: 2d 20 73 74 61 72 74 2d 74 69 6d 65 20 6c 61 73 - start-time las
61e0: 74 2d 74 69 6d 65 29 20 36 30 29 29 0a 09 09 20 t-time) 60))...
61f0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 73 (begin... (s
6200: 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 20 73 74 et! last-time st
6210: 61 72 74 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 art-time)...
6220: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6230: 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 4 *default-log
6240: 2d 70 6f 72 74 2a 20 22 74 69 6d 65 73 74 61 6d -port* "timestam
6250: 70 20 2d 3e 20 22 20 28 73 65 63 6f 6e 64 73 2d p -> " (seconds-
6260: 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 28 63 75 >time-string (cu
6270: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 rrent-seconds))
6280: 22 2c 20 74 69 6d 65 20 73 69 6e 63 65 20 73 74 ", time since st
6290: 61 72 74 20 2d 3e 20 22 20 28 73 65 63 6f 6e 64 art -> " (second
62a0: 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d s->hr-min-sec (-
62b0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
62c0: 73 29 20 2a 74 69 6d 65 2d 7a 65 72 6f 2a 29 29 s) *time-zero*))
62d0: 29 29 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 )))).. ..
62e0: 3b 3b 20 6b 65 65 70 20 67 6f 69 6e 67 20 75 6e ;; keep going un
62f0: 6c 65 73 73 20 74 69 6d 65 20 74 6f 20 65 78 69 less time to exi
6300: 74 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 t.. ;;.. (
6310: 69 66 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f if (not *time-to
6320: 2d 65 78 69 74 2a 29 0a 09 09 28 6c 65 74 20 64 -exit*)...(let d
6330: 65 6c 61 79 2d 6c 6f 6f 70 20 28 28 63 6f 75 6e elay-loop ((coun
6340: 74 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 t 0)).
6350: 20 20 20 20 20 20 20 20 3b 3b 28 64 65 62 75 67 ;;(debug
6360: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a :print-info 13 *
6370: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6380: 2a 20 22 64 65 6c 61 79 2d 6c 6f 6f 70 20 74 6f * "delay-loop to
6390: 70 3b 20 63 6f 75 6e 74 3d 22 63 6f 75 6e 74 22 p; count="count"
63a0: 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 pid="(current-p
63b0: 72 6f 63 65 73 73 2d 69 64 29 22 20 74 68 69 73 rocess-id)" this
63c0: 2d 77 64 2d 6e 75 6d 3d 22 74 68 69 73 2d 77 64 -wd-num="this-wd
63d0: 2d 6e 75 6d 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 -num" *time-to-e
63e0: 78 69 74 2a 3d 22 2a 74 69 6d 65 2d 74 6f 2d 65 xit*="*time-to-e
63f0: 78 69 74 2a 29 0a 20 20 20 20 20 20 20 20 20 20 xit*).
6400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6430: 20 20 0a 09 09 20 20 28 69 66 20 28 61 6e 64 20 ... (if (and
6440: 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 (not *time-to-ex
6450: 69 74 2a 29 0a 09 09 09 20 20 20 28 3c 20 63 6f it*).... (< co
6460: 75 6e 74 20 36 29 29 20 3b 3b 20 77 61 73 20 31 unt 6)) ;; was 1
6470: 31 2c 20 63 68 61 6e 67 69 6e 67 20 74 6f 20 34 1, changing to 4
6480: 2e 20 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 . ... (begi
6490: 6e 0a 09 09 09 28 74 68 72 65 61 64 2d 73 6c 65 n....(thread-sle
64a0: 65 70 21 20 31 29 0a 09 09 09 28 64 65 6c 61 79 ep! 1)....(delay
64b0: 2d 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 -loop (+ count 1
64c0: 29 29 29 29 0a 09 09 20 20 28 69 66 20 28 6e 6f ))))... (if (no
64d0: 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a t *time-to-exit*
64e0: 29 20 28 6c 6f 6f 70 29 29 29 29 0a 09 20 20 20 ) (loop))))..
64f0: 20 3b 3b 20 74 69 6d 65 20 74 6f 20 65 78 69 74 ;; time to exit
6500: 2c 20 63 6c 6f 73 65 20 74 68 65 20 6e 6f 2d 73 , close the no-s
6510: 79 6e 63 20 64 62 20 68 65 72 65 0a 09 20 20 20 ync db here..
6520: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 63 6c 6f (db:no-sync-clo
6530: 73 65 2d 64 62 20 6e 6f 2d 73 79 6e 63 2d 64 62 se-db no-sync-db
6540: 29 0a 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d ).. (if (comm
6550: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
6560: 6e 74 20 33 30 29 0a 09 09 28 64 65 62 75 67 3a nt 30)...(debug:
6570: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
6580: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
6590: 22 45 78 69 74 69 6e 67 20 77 61 74 63 68 64 6f "Exiting watchdo
65a0: 67 20 74 69 6d 65 72 2c 20 2a 74 69 6d 65 2d 74 g timer, *time-t
65b0: 6f 2d 65 78 69 74 2a 20 3d 20 22 20 2a 74 69 6d o-exit* = " *tim
65c0: 65 2d 74 6f 2d 65 78 69 74 2a 22 20 70 69 64 3d e-to-exit*" pid=
65d0: 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 "(current-proces
65e0: 73 2d 69 64 29 20 29 29 29 29 29 29 29 20 3b 3b s-id) ))))))) ;;
65f0: 22 20 74 68 69 73 2d 77 64 2d 6e 75 6d 3d 22 74 " this-wd-num="t
6600: 68 69 73 2d 77 64 2d 6e 75 6d 29 29 29 29 29 29 his-wd-num))))))
6610: 29 0a 0a )..