Artifact
bdeaf16066ebbbea910c3bf348df5cc761aaecfe:
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 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 This file is pa
0040: 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a rt of Megatest..
0050: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
0060: 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 est is free soft
0070: 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 ware: you can re
0080: 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e distribute it an
0090: 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 d/or modify.;;
00a0: 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 it under the
00b0: 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 terms of the GNU
00c0: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
00d0: 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 License as publi
00e0: 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 shed by.;; t
00f0: 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 he Free Software
0100: 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 Foundation, eit
0110: 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 her version 3 of
0120: 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 the License, or
0130: 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 .;; (at your
0140: 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 option) any lat
0150: 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a er version..;; .
0160: 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 ;; Megatest
0170: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 is distributed i
0180: 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 n the hope that
0190: 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 it will be usefu
01a0: 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 l,.;; but WI
01b0: 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e THOUT ANY WARRAN
01c0: 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e TY; without even
01d0: 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 the implied war
01e0: 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 ranty of.;;
01f0: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0200: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0210: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0220: 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b OSE. See the.;;
0230: 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c GNU General
0240: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0250: 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 for more details
0260: 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 ..;; .;; You
0270: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 should have rec
0280: 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 eived a copy of
0290: 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 the GNU General
02a0: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b Public License.;
02b0: 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 ; along with
02c0: 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e Megatest. If n
02d0: 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f ot, see <http://
02e0: 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 www.gnu.org/lice
02f0: 6e 73 65 73 2f 3e 2e 0a 3b 3b 0a 0a 28 72 65 71 nses/>..;;..(req
0300: 75 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 uire-extension (
0310: 73 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 srfi 18) extras
0320: 74 63 70 20 73 31 31 6e 29 0a 0a 28 75 73 65 20 tcp s11n)..(use
0330: 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 srfi-1 posix reg
0340: 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 ex regex-case sr
0350: 66 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d fi-69 hostinfo m
0360: 64 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 d5 message-diges
0370: 74 0a 20 20 20 20 20 64 69 72 65 63 74 6f 72 79 t. directory
0380: 2d 75 74 69 6c 73 20 70 6f 73 69 78 2d 65 78 74 -utils posix-ext
0390: 72 61 73 20 6d 61 74 63 68 61 62 6c 65 29 0a 0a ras matchable)..
03a0: 28 75 73 65 20 73 70 69 66 66 79 20 75 72 69 2d (use spiffy uri-
03b0: 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 common intarweb
03c0: 68 74 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 http-client spif
03d0: 66 79 2d 72 65 71 75 65 73 74 2d 76 61 72 73 29 fy-request-vars)
03e0: 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 ..(declare (unit
03f0: 20 73 65 72 76 65 72 29 29 0a 0a 28 64 65 63 6c server))..(decl
0400: 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e are (uses common
0410: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0420: 73 20 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 s db)).(declare
0430: 28 75 73 65 73 20 74 61 73 6b 73 29 29 20 3b 3b (uses tasks)) ;;
0440: 20 74 61 73 6b 73 20 61 72 65 20 77 68 65 72 65 tasks are where
0450: 20 73 74 75 66 66 20 69 73 20 6d 61 69 6e 74 61 stuff is mainta
0460: 69 6e 65 64 20 61 62 6f 75 74 20 77 68 61 74 20 ined about what
0470: 69 73 20 72 75 6e 6e 69 6e 67 2e 0a 28 64 65 63 is running..(dec
0480: 6c 61 72 65 20 28 75 73 65 73 20 68 74 74 70 2d lare (uses http-
0490: 74 72 61 6e 73 70 6f 72 74 29 29 0a 28 64 65 63 transport)).(dec
04a0: 6c 61 72 65 20 28 75 73 65 73 20 6c 61 75 6e 63 lare (uses launc
04b0: 68 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 h))..(declare (u
04c0: 73 65 73 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a ses commonmod)).
04d0: 28 69 6d 70 6f 72 74 20 63 6f 6d 6d 6f 6e 6d 6f (import commonmo
04e0: 64 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f d)..(include "co
04f0: 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d mmon_records.scm
0500: 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f ").(include "db_
0510: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 records.scm")..(
0520: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6d define (server:m
0530: 61 6b 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 68 ake-server-url h
0540: 6f 73 74 70 6f 72 74 29 0a 20 20 28 69 66 20 28 ostport). (if (
0550: 6e 6f 74 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 not hostport).
0560: 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 63 6f #f. (co
0570: 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 28 63 61 nc "http://" (ca
0580: 72 20 68 6f 73 74 70 6f 72 74 29 20 22 3a 22 20 r hostport) ":"
0590: 28 63 61 64 72 20 68 6f 73 74 70 6f 72 74 29 29 (cadr hostport))
05a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 20 2a 73 65 ))..(define *se
05b0: 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 2d rver-loop-heart-
05c0: 62 65 61 74 2a 20 28 63 75 72 72 65 6e 74 2d 73 beat* (current-s
05d0: 65 63 6f 6e 64 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d econds))..;;====
05e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0620: 3d 3d 0a 3b 3b 20 50 20 4b 20 54 20 53 20 20 20 ==.;; P K T S
0630: 53 20 54 20 55 20 46 20 46 20 0a 3b 3b 3d 3d 3d S T U F F .;;===
0640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0680: 3d 3d 3d 0a 0a 3b 3b 20 3f 3f 3f 0a 0a 3b 3b 3d ===..;; ???..;;=
0690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06d0: 3d 3d 3d 3d 3d 0a 3b 3b 20 50 20 4b 20 54 20 53 =====.;; P K T S
06e0: 20 20 20 53 20 54 20 55 20 46 20 46 20 0a 3b 3b S T U F F .;;
06f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 3f 3f 3f 0a 0a ======..;; ???..
0740: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 ========.;; S E
0790: 52 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d R V E R.;;======
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07e0: 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 74 ..;; Call this t
07f0: 6f 20 73 74 61 72 74 20 74 68 65 20 61 63 74 75 o start the actu
0800: 61 6c 20 73 65 72 76 65 72 0a 3b 3b 0a 0a 3b 3b al server.;;..;;
0810: 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 68 6f 75 all routes thou
0820: 67 68 20 68 65 72 65 20 65 6e 64 20 69 6e 20 65 gh here end in e
0830: 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 73 74 xit ....;;.;; st
0840: 61 72 74 5f 73 65 72 76 65 72 0a 3b 3b 0a 28 64 art_server.;;.(d
0850: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6c 61 efine (server:la
0860: 75 6e 63 68 20 72 75 6e 2d 69 64 20 74 72 61 6e unch run-id tran
0870: 73 70 6f 72 74 2d 74 79 70 65 29 0a 20 20 28 68 sport-type). (h
0880: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 ttp-transport:la
0890: 75 6e 63 68 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d unch))..;;======
08a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08e0: 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 20 .;; S E R V E R
08f0: 20 20 55 20 54 20 49 20 4c 20 49 20 54 20 49 20 U T I L I T I
0900: 45 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d E S .;;=========
0910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
0950: 3b 20 47 65 74 20 74 68 65 20 74 72 61 6e 73 70 ; Get the transp
0960: 6f 72 74 0a 28 64 65 66 69 6e 65 20 28 73 65 72 ort.(define (ser
0970: 76 65 72 3a 67 65 74 2d 74 72 61 6e 73 70 6f 72 ver:get-transpor
0980: 74 29 20 27 68 74 74 70 29 0a 09 20 20 20 20 0a t) 'http).. .
0990: 3b 3b 20 47 65 6e 65 72 61 74 65 20 61 20 75 6e ;; Generate a un
09a0: 69 71 75 65 20 73 69 67 6e 61 74 75 72 65 20 66 ique signature f
09b0: 6f 72 20 74 68 69 73 20 73 65 72 76 65 72 0a 28 or this server.(
09c0: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6d define (server:m
09d0: 6b 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 k-signature). (
09e0: 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 message-digest-s
09f0: 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 tring (md5-primi
0a00: 74 69 76 65 29 20 0a 09 09 09 20 28 77 69 74 68 tive) .... (with
0a10: 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e -output-to-strin
0a20: 67 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 61 20 g.... (lambda
0a30: 28 29 0a 09 09 09 20 20 20 20 20 28 77 72 69 74 ().... (writ
0a40: 65 20 28 6c 69 73 74 20 28 63 75 72 72 65 6e 74 e (list (current
0a50: 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 09 09 09 -directory).....
0a60: 09 20 20 28 61 72 67 76 29 29 29 29 29 29 29 0a . (argv))))))).
0a70: 0a 3b 3b 20 57 68 65 6e 20 75 73 69 6e 67 20 7a .;; When using z
0a80: 6d 71 20 74 68 69 73 20 77 6f 75 6c 64 20 73 65 mq this would se
0a90: 6e 64 20 74 68 65 20 6d 65 73 73 61 67 65 20 62 nd the message b
0aa0: 61 63 6b 20 28 74 77 6f 20 73 74 65 70 20 70 72 ack (two step pr
0ab0: 6f 63 65 73 73 29 0a 3b 3b 20 77 69 74 68 20 73 ocess).;; with s
0ac0: 70 69 66 66 79 20 6f 72 20 72 70 63 20 74 68 69 piffy or rpc thi
0ad0: 73 20 73 69 6d 70 6c 79 20 72 65 74 75 72 6e 73 s simply returns
0ae0: 20 74 68 65 20 72 65 74 75 72 6e 20 64 61 74 61 the return data
0af0: 20 74 6f 20 62 65 20 72 65 74 75 72 6e 65 64 0a to be returned.
0b00: 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 65 72 ;; .(define (ser
0b10: 76 65 72 3a 72 65 70 6c 79 20 72 65 74 75 72 6e ver:reply return
0b20: 2d 61 64 64 72 20 71 75 65 72 79 2d 73 69 67 20 -addr query-sig
0b30: 73 75 63 63 65 73 73 2f 66 61 69 6c 20 72 65 73 success/fail res
0b40: 75 6c 74 29 0a 20 20 28 64 65 62 75 67 3a 70 72 ult). (debug:pr
0b50: 69 6e 74 2d 69 6e 66 6f 20 31 31 20 2a 64 65 66 int-info 11 *def
0b60: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
0b70: 73 65 72 76 65 72 3a 72 65 70 6c 79 20 72 65 74 server:reply ret
0b80: 75 72 6e 2d 61 64 64 72 3d 22 20 72 65 74 75 72 urn-addr=" retur
0b90: 6e 2d 61 64 64 72 20 22 2c 20 72 65 73 75 6c 74 n-addr ", result
0ba0: 3d 22 20 72 65 73 75 6c 74 29 0a 20 20 28 64 62 =" result). (db
0bb0: 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 28 76 65 :obj->string (ve
0bc0: 63 74 6f 72 20 73 75 63 63 65 73 73 2f 66 61 69 ctor success/fai
0bd0: 6c 20 71 75 65 72 79 2d 73 69 67 20 72 65 73 75 l query-sig resu
0be0: 6c 74 29 29 29 20 20 3b 3b 20 28 73 65 6e 64 2d lt))) ;; (send-
0bf0: 6d 65 73 73 61 67 65 20 70 75 62 73 6f 63 6b 20 message pubsock
0c00: 74 61 72 67 65 74 20 73 65 6e 64 2d 6d 6f 72 65 target send-more
0c10: 3a 20 23 74 29 0a 0a 3b 3b 20 47 69 76 65 6e 20 : #t)..;; Given
0c20: 61 20 72 75 6e 20 69 64 20 73 74 61 72 74 20 61 a run id start a
0c30: 20 73 65 72 76 65 72 20 70 72 6f 63 65 73 73 20 server process
0c40: 20 20 20 23 23 23 20 4e 4f 54 45 20 23 23 23 20 ### NOTE ###
0c50: 3e 20 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 > file 2>&1 .;;
0c60: 69 66 20 74 68 65 20 72 75 6e 2d 69 64 20 69 73 if the run-id is
0c70: 20 7a 65 72 6f 20 61 6e 64 20 74 68 65 20 74 61 zero and the ta
0c80: 72 67 65 74 2d 68 6f 73 74 20 69 73 20 73 65 74 rget-host is set
0c90: 20 0a 3b 3b 20 74 72 79 20 72 75 6e 6e 69 6e 67 .;; try running
0ca0: 20 6f 6e 20 74 68 61 74 20 68 6f 73 74 0a 3b 3b on that host.;;
0cb0: 20 20 20 69 6e 63 69 64 65 6e 74 61 6c 3a 20 72 incidental: r
0cc0: 6f 74 61 74 65 20 6c 6f 67 73 20 69 6e 20 6c 6f otate logs in lo
0cd0: 67 73 2f 20 64 69 72 2e 0a 3b 3b 0a 28 64 65 66 gs/ dir..;;.(def
0ce0: 69 6e 65 20 20 28 73 65 72 76 65 72 3a 72 75 6e ine (server:run
0cf0: 20 61 72 65 61 70 61 74 68 29 20 3b 3b 20 61 72 areapath) ;; ar
0d00: 65 61 70 61 74 68 20 69 73 20 2a 74 6f 70 70 61 eapath is *toppa
0d10: 74 68 2a 20 66 6f 72 20 61 20 67 69 76 65 6e 20 th* for a given
0d20: 74 65 73 74 73 75 69 74 65 20 61 72 65 61 0a 20 testsuite area.
0d30: 20 28 6c 65 74 2a 20 28 28 63 75 72 72 2d 68 6f (let* ((curr-ho
0d40: 73 74 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e st (get-host-n
0d50: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 3b ame)). ;
0d60: 3b 20 28 61 74 74 65 6d 70 74 2d 69 6e 2d 70 72 ; (attempt-in-pr
0d70: 6f 67 72 65 73 73 20 28 73 65 72 76 65 72 3a 73 ogress (server:s
0d80: 74 61 72 74 2d 61 74 74 65 6d 70 74 65 64 3f 20 tart-attempted?
0d90: 61 72 65 61 70 61 74 68 29 29 0a 20 20 20 20 20 areapath)).
0da0: 20 20 20 20 3b 3b 20 28 64 6f 74 2d 73 65 72 76 ;; (dot-serv
0db0: 65 72 2d 75 72 6c 20 28 73 65 72 76 65 72 3a 63 er-url (server:c
0dc0: 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 heck-if-running
0dd0: 61 72 65 61 70 61 74 68 29 29 0a 09 20 28 63 75 areapath)).. (cu
0de0: 72 72 2d 69 70 20 20 20 20 20 28 73 65 72 76 65 rr-ip (serve
0df0: 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 r:get-best-guess
0e00: 2d 61 64 64 72 65 73 73 20 63 75 72 72 2d 68 6f -address curr-ho
0e10: 73 74 29 29 0a 09 20 28 63 75 72 72 2d 70 69 64 st)).. (curr-pid
0e20: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f (current-pro
0e30: 63 65 73 73 2d 69 64 29 29 0a 09 20 28 68 6f 6d cess-id)).. (hom
0e40: 65 68 6f 73 74 20 20 20 20 28 63 6f 6d 6d 6f 6e ehost (common
0e50: 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 20 :get-homehost))
0e60: 3b 3b 20 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ;; configf:looku
0e70: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
0e80: 65 72 76 65 72 22 20 22 68 6f 6d 65 68 6f 73 74 erver" "homehost
0e90: 22 20 29 29 0a 09 20 28 74 61 72 67 65 74 2d 68 " )).. (target-h
0ea0: 6f 73 74 20 28 63 61 72 20 68 6f 6d 65 68 6f 73 ost (car homehos
0eb0: 74 29 29 0a 09 20 28 74 65 73 74 73 75 69 74 65 t)).. (testsuite
0ec0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 (common:get-a
0ed0: 72 65 61 2d 6e 61 6d 65 20 2a 61 6c 6c 64 61 74 rea-name *alldat
0ee0: 2a 29 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 *)).. (logfile
0ef0: 20 20 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 (conc areapat
0f00: 68 20 22 2f 6c 6f 67 73 2f 73 65 72 76 65 72 2e h "/logs/server.
0f10: 6c 6f 67 22 29 29 20 3b 3b 20 2d 22 20 63 75 72 log")) ;; -" cur
0f20: 72 2d 70 69 64 20 22 2d 22 20 74 61 72 67 65 74 r-pid "-" target
0f30: 2d 68 6f 73 74 20 22 2e 6c 6f 67 22 29 29 0a 09 -host ".log"))..
0f40: 20 28 63 6d 64 6c 6e 20 28 63 6f 6e 63 20 28 63 (cmdln (conc (c
0f50: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 ommon:get-megate
0f60: 73 74 2d 65 78 65 29 0a 09 09 20 20 20 20 20 20 st-exe)...
0f70: 22 20 2d 73 65 72 76 65 72 20 22 20 28 6f 72 20 " -server " (or
0f80: 74 61 72 67 65 74 2d 68 6f 73 74 20 22 2d 22 29 target-host "-")
0f90: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 6f (if (equal? (co
0fa0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
0fb0: 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 nfigdat* "server
0fc0: 22 20 22 64 61 65 6d 6f 6e 69 7a 65 22 29 20 22 " "daemonize") "
0fd0: 79 65 73 22 29 0a 09 09 09 09 09 09 09 20 20 20 yes")........
0fe0: 22 20 2d 64 61 65 6d 6f 6e 69 7a 65 20 22 0a 09 " -daemonize "..
0ff0: 09 09 09 09 09 09 20 20 20 22 22 29 0a 09 09 20 ...... "")...
1000: 20 20 20 20 20 3b 3b 20 22 20 2d 6c 6f 67 20 22 ;; " -log "
1010: 20 6c 6f 67 66 69 6c 65 0a 09 09 20 20 20 20 20 logfile...
1020: 20 22 20 2d 6d 20 74 65 73 74 73 75 69 74 65 3a " -m testsuite:
1030: 22 20 74 65 73 74 73 75 69 74 65 29 29 20 3b 3b " testsuite)) ;;
1040: 20 28 63 6f 6e 63 20 22 20 3e 3e 20 22 20 6c 6f (conc " >> " lo
1050: 67 66 69 6c 65 20 22 20 32 3e 26 31 20 26 22 29 gfile " 2>&1 &")
1060: 29 29 29 29 0a 09 20 28 6c 6f 67 2d 72 6f 74 61 )))).. (log-rota
1070: 74 65 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 te (make-thread
1080: 20 63 6f 6d 6d 6f 6e 3a 72 6f 74 61 74 65 2d 6c common:rotate-l
1090: 6f 67 73 20 20 22 73 65 72 76 65 72 20 72 75 6e ogs "server run
10a0: 2c 20 72 6f 74 61 74 65 20 6c 6f 67 73 20 74 68 , rotate logs th
10b0: 72 65 61 64 22 29 29 0a 20 20 20 20 20 20 20 20 read")).
10c0: 20 28 6c 6f 61 64 2d 6c 69 6d 69 74 20 20 28 63 (load-limit (c
10d0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 onfigf:lookup-nu
10e0: 6d 62 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a mber *configdat*
10f0: 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 6d 61 78 "jobtools" "max
1100: 2d 73 65 72 76 65 72 2d 73 74 61 72 74 2d 6c 6f -server-start-lo
1110: 61 64 22 20 64 65 66 61 75 6c 74 3a 20 33 2e 30 ad" default: 3.0
1120: 29 29 29 0a 20 20 20 20 3b 3b 20 77 65 20 77 61 ))). ;; we wa
1130: 6e 74 20 74 68 65 20 72 65 6d 6f 74 65 20 73 65 nt the remote se
1140: 72 76 65 72 20 74 6f 20 73 74 61 72 74 20 69 6e rver to start in
1150: 20 2a 74 6f 70 70 61 74 68 2a 20 73 6f 20 70 75 *toppath* so pu
1160: 73 68 20 74 68 65 72 65 0a 20 20 20 20 28 70 75 sh there. (pu
1170: 73 68 2d 64 69 72 65 63 74 6f 72 79 20 61 72 65 sh-directory are
1180: 61 70 61 74 68 29 0a 20 20 20 20 28 64 65 62 75 apath). (debu
1190: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
11a0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
11b0: 46 4f 3a 20 54 72 79 69 6e 67 20 74 6f 20 73 74 FO: Trying to st
11c0: 61 72 74 20 73 65 72 76 65 72 20 28 22 20 63 6d art server (" cm
11d0: 64 6c 6e 20 22 29 20 2e 2e 2e 22 29 0a 20 20 20 dln ") ...").
11e0: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
11f0: 6c 6f 67 2d 72 6f 74 61 74 65 29 0a 20 20 20 20 log-rotate).
1200: 0a 20 20 20 20 3b 3b 20 68 6f 73 74 2e 64 6f 6d . ;; host.dom
1210: 61 69 6e 2e 74 6c 64 20 6d 61 74 63 68 20 68 6f ain.tld match ho
1220: 73 74 3f 0a 20 20 20 20 28 69 66 20 28 61 6e 64 st?. (if (and
1230: 20 74 61 72 67 65 74 2d 68 6f 73 74 20 0a 09 20 target-host ..
1240: 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 ;; look at t
1250: 61 72 67 65 74 20 68 6f 73 74 2c 20 69 73 20 69 arget host, is i
1260: 74 20 68 6f 73 74 2e 64 6f 6d 61 69 6e 2e 74 6c t host.domain.tl
1270: 64 20 6f 72 20 69 70 20 61 64 64 72 65 73 73 20 d or ip address
1280: 61 6e 64 20 64 6f 65 73 20 69 74 20 0a 09 20 20 and does it ..
1290: 20 20 20 3b 3b 20 6d 61 74 63 68 20 63 75 72 72 ;; match curr
12a0: 65 6e 74 20 69 70 20 6f 72 20 68 6f 73 74 6e 61 ent ip or hostna
12b0: 6d 65 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 73 me.. (not (s
12c0: 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 63 6f 6e tring-match (con
12d0: 63 20 22 28 22 63 75 72 72 2d 68 6f 73 74 20 22 c "("curr-host "
12e0: 7c 22 20 63 75 72 72 2d 68 6f 73 74 22 5c 5c 2e |" curr-host"\\.
12f0: 2e 2a 29 22 29 20 74 61 72 67 65 74 2d 68 6f 73 .*)") target-hos
1300: 74 29 29 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 t)).. (not (
1310: 65 71 75 61 6c 3f 20 63 75 72 72 2d 69 70 20 74 equal? curr-ip t
1320: 61 72 67 65 74 2d 68 6f 73 74 29 29 29 0a 09 28 arget-host)))..(
1330: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
1340: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
1350: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1360: 22 53 74 61 72 74 69 6e 67 20 73 65 72 76 65 72 "Starting server
1370: 20 6f 6e 20 22 20 74 61 72 67 65 74 2d 68 6f 73 on " target-hos
1380: 74 20 22 2c 20 6c 6f 67 66 69 6c 65 20 69 73 20 t ", logfile is
1390: 22 20 6c 6f 67 66 69 6c 65 29 0a 09 20 20 28 73 " logfile).. (s
13a0: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
13b0: 54 22 20 74 61 72 67 65 74 2d 68 6f 73 74 29 29 T" target-host))
13c0: 29 0a 20 20 20 20 20 20 0a 20 20 20 20 28 73 65 ). . (se
13d0: 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 tenv "TARGETHOST
13e0: 5f 4c 4f 47 46 22 20 6c 6f 67 66 69 6c 65 29 0a _LOGF" logfile).
13f0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
1400: 70 21 20 28 2f 20 28 72 61 6e 64 6f 6d 20 35 30 p! (/ (random 50
1410: 30 30 29 20 31 30 30 30 29 29 20 3b 3b 20 61 64 00) 1000)) ;; ad
1420: 64 20 61 62 6f 75 74 20 61 20 72 61 6e 64 6f 6d d about a random
1430: 20 28 75 70 20 74 6f 20 35 20 73 65 63 6f 6e 64 (up to 5 second
1440: 73 29 20 69 6e 69 74 69 61 6c 20 64 65 6c 61 79 s) initial delay
1450: 2e 20 49 74 20 73 65 65 6d 73 20 70 72 65 74 74 . It seems prett
1460: 79 20 63 6f 6d 6d 6f 6e 20 74 68 61 74 20 6d 61 y common that ma
1470: 6e 79 20 72 75 6e 6e 69 6e 67 20 74 65 73 74 73 ny running tests
1480: 20 72 65 71 75 65 73 74 20 61 20 73 65 72 76 65 request a serve
1490: 72 20 61 74 20 74 68 65 20 73 61 6d 65 20 74 69 r at the same ti
14a0: 6d 65 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 me. (common:w
14b0: 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a ait-for-normaliz
14c0: 65 64 2d 6c 6f 61 64 20 6c 6f 61 64 2d 6c 69 6d ed-load load-lim
14d0: 69 74 20 22 20 64 65 6c 61 79 69 6e 67 20 73 65 it " delaying se
14e0: 72 76 65 72 20 73 74 61 72 74 20 64 75 65 20 74 rver start due t
14f0: 6f 20 6c 6f 61 64 22 20 74 61 72 67 65 74 2d 68 o load" target-h
1500: 6f 73 74 29 20 3b 3b 20 64 6f 20 6e 6f 74 20 74 ost) ;; do not t
1510: 72 79 20 73 74 61 72 74 69 6e 67 20 73 65 72 76 ry starting serv
1520: 65 72 73 20 6f 6e 20 61 6e 20 61 6c 72 65 61 64 ers on an alread
1530: 79 20 6f 76 65 72 6c 6f 61 64 65 64 20 6d 61 63 y overloaded mac
1540: 68 69 6e 65 2c 20 6a 75 73 74 20 77 61 69 74 20 hine, just wait
1550: 66 6f 72 65 76 65 72 0a 20 20 20 20 28 73 79 73 forever. (sys
1560: 74 65 6d 20 28 63 6f 6e 63 20 22 6e 62 66 61 6b tem (conc "nbfak
1570: 65 20 22 20 63 6d 64 6c 6e 29 29 0a 20 20 20 20 e " cmdln)).
1580: 28 75 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 (unsetenv "TARGE
1590: 54 48 4f 53 54 5f 4c 4f 47 46 22 29 0a 20 20 20 THOST_LOGF").
15a0: 20 28 69 66 20 28 67 65 74 2d 65 6e 76 69 72 6f (if (get-enviro
15b0: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
15c0: 54 41 52 47 45 54 48 4f 53 54 22 29 28 75 6e 73 TARGETHOST")(uns
15d0: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
15e0: 54 22 29 29 0a 20 20 20 20 28 74 68 72 65 61 64 T")). (thread
15f0: 2d 6a 6f 69 6e 21 20 6c 6f 67 2d 72 6f 74 61 74 -join! log-rotat
1600: 65 29 0a 20 20 20 20 28 70 6f 70 2d 64 69 72 65 e). (pop-dire
1610: 63 74 6f 72 79 29 29 29 0a 0a 3b 3b 20 67 69 76 ctory)))..;; giv
1620: 65 6e 20 61 20 70 61 74 68 20 74 6f 20 61 20 73 en a path to a s
1630: 65 72 76 65 72 20 6c 6f 67 20 72 65 74 75 72 6e erver log return
1640: 3a 20 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 : host port star
1650: 74 73 65 63 6f 6e 64 73 0a 3b 3b 0a 28 64 65 66 tseconds.;;.(def
1660: 69 6e 65 20 28 73 65 72 76 65 72 3a 6c 6f 67 66 ine (server:logf
1670: 2d 67 65 74 2d 73 74 61 72 74 2d 69 6e 66 6f 20 -get-start-info
1680: 6c 6f 67 66 29 0a 20 20 28 6c 65 74 20 28 28 72 logf). (let ((r
1690: 78 20 28 72 65 67 65 78 70 20 22 5e 53 45 52 56 x (regexp "^SERV
16a0: 45 52 20 53 54 41 52 54 45 44 3a 20 28 5c 5c 53 ER STARTED: (\\S
16b0: 2b 29 3a 28 5c 5c 64 2b 29 20 41 54 20 28 5b 5c +):(\\d+) AT ([\
16c0: 5c 64 5c 5c 2e 5d 2b 29 22 29 29 29 20 3b 3b 20 \d\\.]+)"))) ;;
16d0: 53 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 SERVER STARTED:
16e0: 68 6f 73 74 3a 70 6f 72 74 20 41 54 20 74 69 6d host:port AT tim
16f0: 65 73 65 63 73 0a 20 20 20 20 28 68 61 6e 64 6c esecs. (handl
1700: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 65 78 e-exceptions..ex
1710: 6e 0a 09 28 6c 69 73 74 20 23 66 20 23 66 20 23 n..(list #f #f #
1720: 66 29 20 3b 3b 20 6e 6f 20 69 64 65 61 20 77 68 f) ;; no idea wh
1730: 61 74 20 77 65 6e 74 20 77 72 6f 6e 67 2c 20 63 at went wrong, c
1740: 61 6c 6c 20 69 74 20 61 20 62 61 64 20 73 65 72 all it a bad ser
1750: 76 65 72 0a 20 20 20 20 20 20 28 77 69 74 68 2d ver. (with-
1760: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 0a input-from-file.
1770: 09 20 20 6c 6f 67 66 0a 09 28 6c 61 6d 62 64 61 . logf..(lambda
1780: 20 28 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 ().. (let loop
1790: 20 28 28 69 6e 6c 20 20 28 72 65 61 64 2d 6c 69 ((inl (read-li
17a0: 6e 65 29 29 0a 09 09 20 20 20 20 20 28 6c 6e 75 ne))... (lnu
17b0: 6d 20 30 29 29 0a 09 20 20 20 20 28 69 66 20 28 m 0)).. (if (
17c0: 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f not (eof-object?
17d0: 20 69 6e 6c 29 29 0a 09 09 28 6c 65 74 20 28 28 inl))...(let ((
17e0: 6d 6c 73 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 mlst (string-mat
17f0: 63 68 20 72 78 20 69 6e 6c 29 29 29 0a 09 09 20 ch rx inl)))...
1800: 20 28 69 66 20 28 6e 6f 74 20 6d 6c 73 74 29 0a (if (not mlst).
1810: 09 09 20 20 20 20 20 20 28 69 66 20 28 3c 20 6c .. (if (< l
1820: 6e 75 6d 20 35 30 30 29 20 3b 3b 20 67 69 76 65 num 500) ;; give
1830: 20 75 70 20 69 66 20 6d 6f 72 65 20 74 68 61 6e up if more than
1840: 20 35 30 30 20 6c 69 6e 65 73 20 6f 66 20 73 65 500 lines of se
1850: 72 76 65 72 20 6c 6f 67 20 72 65 61 64 0a 09 09 rver log read...
1860: 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c . (loop (read-l
1870: 69 6e 65 29 28 2b 20 6c 6e 75 6d 20 31 29 29 0a ine)(+ lnum 1)).
1880: 09 09 09 20 20 28 6c 69 73 74 20 23 66 20 23 66 ... (list #f #f
1890: 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 28 6c #f))... (l
18a0: 65 74 20 28 28 64 61 74 20 20 28 63 64 72 20 6d et ((dat (cdr m
18b0: 6c 73 74 29 29 29 0a 09 09 09 28 6c 69 73 74 20 lst)))....(list
18c0: 28 63 61 72 20 64 61 74 29 20 3b 3b 20 68 6f 73 (car dat) ;; hos
18d0: 74 0a 09 09 09 20 20 20 20 20 20 28 73 74 72 69 t.... (stri
18e0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 ng->number (cadr
18f0: 20 64 61 74 29 29 20 3b 3b 20 70 6f 72 74 0a 09 dat)) ;; port..
1900: 09 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d .. (string-
1910: 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 72 20 64 >number (caddr d
1920: 61 74 29 29 29 29 29 29 0a 09 09 28 6c 69 73 74 at))))))...(list
1930: 20 23 66 20 23 66 20 23 66 29 29 29 29 29 29 29 #f #f #f)))))))
1940: 29 0a 0a 3b 3b 20 67 65 74 20 61 20 6c 69 73 74 )..;; get a list
1950: 20 6f 66 20 73 65 72 76 65 72 73 20 77 69 74 68 of servers with
1960: 20 61 6c 6c 20 72 65 6c 65 76 61 6e 74 20 64 61 all relevant da
1970: 74 61 0a 3b 3b 20 28 20 6d 6f 64 2d 74 69 6d 65 ta.;; ( mod-time
1980: 20 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 host port start
1990: 2d 74 69 6d 65 20 70 69 64 20 29 0a 3b 3b 0a 28 -time pid ).;;.(
19a0: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 define (server:g
19b0: 65 74 2d 6c 69 73 74 20 61 72 65 61 70 61 74 68 et-list areapath
19c0: 20 23 21 6b 65 79 20 28 6c 69 6d 69 74 20 23 66 #!key (limit #f
19d0: 29 29 0a 20 20 28 6c 65 74 20 28 28 66 6e 61 6d )). (let ((fnam
19e0: 65 2d 72 78 20 20 20 20 28 72 65 67 65 78 70 20 e-rx (regexp
19f0: 22 5e 28 7c 2e 2a 2f 29 73 65 72 76 65 72 2d 28 "^(|.*/)server-(
1a00: 5c 5c 64 2b 29 2d 28 5c 5c 53 2b 29 2e 6c 6f 67 \\d+)-(\\S+).log
1a10: 24 22 29 29 0a 09 28 64 61 79 2d 73 65 63 6f 6e $"))..(day-secon
1a20: 64 73 20 28 2a 20 32 34 20 36 30 20 36 30 29 29 ds (* 24 60 60))
1a30: 29 0a 20 20 20 20 3b 3b 20 69 66 20 74 68 65 20 ). ;; if the
1a40: 64 69 72 65 63 74 6f 72 79 20 65 78 69 73 74 73 directory exists
1a50: 20 63 6f 6e 74 69 6e 75 65 20 74 6f 20 67 65 74 continue to get
1a60: 20 74 68 65 20 6c 69 73 74 0a 20 20 20 20 3b 3b the list. ;;
1a70: 20 6f 74 68 65 72 77 69 73 65 20 61 74 74 65 6d otherwise attem
1a80: 70 74 20 74 6f 20 63 72 65 61 74 65 20 74 68 65 pt to create the
1a90: 20 6c 6f 67 73 20 64 69 72 20 61 6e 64 20 74 68 logs dir and th
1aa0: 65 6e 0a 20 20 20 20 3b 3b 20 63 6f 6e 74 69 6e en. ;; contin
1ab0: 75 65 0a 20 20 20 20 28 69 66 20 28 69 66 20 28 ue. (if (if (
1ac0: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
1ad0: 3f 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 ? (conc areapath
1ae0: 20 22 2f 6c 6f 67 73 22 29 29 0a 09 20 20 20 20 "/logs"))..
1af0: 27 28 29 0a 09 20 20 20 20 28 69 66 20 28 66 69 '().. (if (fi
1b00: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
1b10: 20 61 72 65 61 70 61 74 68 29 0a 09 09 28 62 65 areapath)...(be
1b20: 67 69 6e 0a 09 09 20 20 28 63 6f 6e 64 69 74 69 gin... (conditi
1b30: 6f 6e 2d 63 61 73 65 0a 09 09 20 20 20 20 20 20 on-case...
1b40: 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 (create-director
1b50: 79 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 y (conc areapath
1b60: 20 22 2f 6c 6f 67 73 22 29 20 23 74 29 0a 09 09 "/logs") #t)...
1b70: 20 20 20 20 28 65 78 6e 20 28 69 2f 6f 20 66 69 (exn (i/o fi
1b80: 6c 65 29 28 64 65 62 75 67 3a 70 72 69 6e 74 20 le)(debug:print
1b90: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1ba0: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 43 61 6e ort* "ERROR: Can
1bb0: 6e 6f 74 20 63 72 65 61 74 65 20 64 69 72 65 63 not create direc
1bc0: 74 6f 72 79 20 61 74 20 22 20 28 63 6f 6e 63 20 tory at " (conc
1bd0: 61 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 22 areapath "/logs"
1be0: 29 29 29 0a 09 09 20 20 20 20 28 65 78 6e 20 28 )))... (exn (
1bf0: 29 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 )(debug:print 0
1c00: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1c10: 74 2a 20 22 45 52 52 4f 52 3a 20 55 6e 6b 6e 6f t* "ERROR: Unkno
1c20: 77 6e 20 65 72 72 6f 72 20 61 74 74 65 6d 74 70 wn error attemtp
1c30: 69 6e 67 20 74 6f 20 67 65 74 20 73 65 72 76 65 ing to get serve
1c40: 72 20 6c 69 73 74 2e 22 29 29 29 0a 09 09 20 20 r list.")))...
1c50: 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 (directory-exist
1c60: 73 3f 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 s? (conc areapat
1c70: 68 20 22 2f 6c 6f 67 73 22 29 29 29 0a 09 09 27 h "/logs")))...'
1c80: 28 29 29 29 0a 09 28 6c 65 74 2a 20 28 28 73 65 ()))..(let* ((se
1c90: 72 76 65 72 2d 6c 6f 67 73 20 20 20 28 67 6c 6f rver-logs (glo
1ca0: 62 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 b (conc areapath
1cb0: 20 22 2f 6c 6f 67 73 2f 73 65 72 76 65 72 2d 2a "/logs/server-*
1cc0: 2e 6c 6f 67 22 29 29 29 0a 09 20 20 20 20 20 20 .log")))..
1cd0: 20 28 6e 75 6d 2d 73 65 72 76 2d 6c 6f 67 73 20 (num-serv-logs
1ce0: 28 6c 65 6e 67 74 68 20 73 65 72 76 65 72 2d 6c (length server-l
1cf0: 6f 67 73 29 29 29 0a 09 20 20 28 69 66 20 28 6e ogs))).. (if (n
1d00: 75 6c 6c 3f 20 73 65 72 76 65 72 2d 6c 6f 67 73 ull? server-logs
1d10: 29 0a 09 20 20 20 20 20 20 27 28 29 0a 09 20 20 ).. '()..
1d20: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
1d30: 68 65 64 20 20 28 63 61 72 20 73 65 72 76 65 72 hed (car server
1d40: 2d 6c 6f 67 73 29 29 0a 09 09 09 20 28 74 61 6c -logs)).... (tal
1d50: 20 20 28 63 64 72 20 73 65 72 76 65 72 2d 6c 6f (cdr server-lo
1d60: 67 73 29 29 0a 09 09 09 20 28 72 65 73 20 27 28 gs)).... (res '(
1d70: 29 29 29 0a 09 09 28 6c 65 74 2a 20 28 28 6d 6f )))...(let* ((mo
1d80: 64 2d 74 69 6d 65 20 20 28 68 61 6e 64 6c 65 2d d-time (handle-
1d90: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 20 exceptions.....
1da0: 20 20 20 20 20 65 78 6e 0a 09 09 09 09 20 20 20 exn.....
1db0: 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (current-seco
1dc0: 6e 64 73 29 20 3b 3b 20 30 0a 09 09 09 09 20 20 nds) ;; 0.....
1dd0: 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 (file-modifica
1de0: 74 69 6f 6e 2d 74 69 6d 65 20 68 65 64 29 29 29 tion-time hed)))
1df0: 20 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f 20 2a ;; default to *
1e00: 76 65 72 79 2a 20 6f 6c 64 20 73 6f 20 6c 6f 67 very* old so log
1e10: 20 67 65 74 73 20 69 67 6e 6f 72 65 64 20 69 66 gets ignored if
1e20: 20 64 65 6c 65 74 65 64 0a 09 09 20 20 20 20 20 deleted...
1e30: 20 20 28 64 6f 77 6e 2d 74 69 6d 65 20 28 2d 20 (down-time (-
1e40: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
1e50: 29 20 6d 6f 64 2d 74 69 6d 65 29 29 0a 09 09 20 ) mod-time))...
1e60: 20 20 20 20 20 20 28 73 65 72 76 2d 64 61 74 20 (serv-dat
1e70: 20 28 69 66 20 28 6f 72 20 28 3c 20 6e 75 6d 2d (if (or (< num-
1e80: 73 65 72 76 2d 6c 6f 67 73 20 31 30 29 0a 09 09 serv-logs 10)...
1e90: 09 09 20 20 09 20 20 28 3c 20 64 6f 77 6e 2d 74 .. . (< down-t
1ea0: 69 6d 65 20 39 30 30 29 29 20 3b 3b 20 64 61 79 ime 900)) ;; day
1eb0: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 09 09 20 -seconds)).....
1ec0: 20 20 20 20 20 28 73 65 72 76 65 72 3a 6c 6f 67 (server:log
1ed0: 66 2d 67 65 74 2d 73 74 61 72 74 2d 69 6e 66 6f f-get-start-info
1ee0: 20 68 65 64 29 0a 09 09 09 09 20 20 20 20 20 20 hed).....
1ef0: 27 28 29 29 29 20 3b 3b 20 64 6f 6e 27 74 20 77 '())) ;; don't w
1f00: 61 73 74 65 20 74 69 6d 65 20 70 72 6f 63 65 73 aste time proces
1f10: 73 69 6e 67 20 73 65 72 76 65 72 20 66 69 6c 65 sing server file
1f20: 73 20 6e 6f 74 20 74 6f 75 63 68 65 64 20 69 6e s not touched in
1f30: 20 74 68 65 20 31 35 20 6d 69 6e 75 74 65 73 20 the 15 minutes
1f40: 69 66 20 74 68 65 72 65 20 61 72 65 20 6d 6f 72 if there are mor
1f50: 65 20 74 68 61 6e 20 74 65 6e 20 73 65 72 76 65 e than ten serve
1f60: 72 73 20 74 6f 20 6c 6f 6f 6b 20 61 74 0a 09 09 rs to look at...
1f70: 20 20 20 20 20 20 20 28 73 65 72 76 2d 72 65 63 (serv-rec
1f80: 20 28 63 6f 6e 73 20 6d 6f 64 2d 74 69 6d 65 20 (cons mod-time
1f90: 73 65 72 76 2d 64 61 74 29 29 0a 09 09 20 20 20 serv-dat))...
1fa0: 20 20 20 20 28 66 6d 61 74 63 68 20 20 20 28 73 (fmatch (s
1fb0: 74 72 69 6e 67 2d 6d 61 74 63 68 20 66 6e 61 6d tring-match fnam
1fc0: 65 2d 72 78 20 68 65 64 29 29 0a 09 09 20 20 20 e-rx hed))...
1fd0: 20 20 20 20 28 70 69 64 20 20 20 20 20 20 28 69 (pid (i
1fe0: 66 20 66 6d 61 74 63 68 20 28 73 74 72 69 6e 67 f fmatch (string
1ff0: 2d 3e 6e 75 6d 62 65 72 20 28 6c 69 73 74 2d 72 ->number (list-r
2000: 65 66 20 66 6d 61 74 63 68 20 32 29 29 20 23 66 ef fmatch 2)) #f
2010: 29 29 0a 09 09 20 20 20 20 20 20 20 28 6e 65 77 ))... (new
2020: 2d 72 65 73 20 20 28 69 66 20 28 6e 75 6c 6c 3f -res (if (null?
2030: 20 73 65 72 76 2d 64 61 74 29 0a 09 09 09 09 20 serv-dat).....
2040: 20 20 20 20 72 65 73 0a 09 09 09 09 20 20 20 20 res.....
2050: 20 28 63 6f 6e 73 20 28 61 70 70 65 6e 64 20 73 (cons (append s
2060: 65 72 76 2d 72 65 63 20 28 6c 69 73 74 20 70 69 erv-rec (list pi
2070: 64 29 29 20 72 65 73 29 29 29 29 0a 09 09 28 69 d)) res))))...(i
2080: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
2090: 20 20 20 20 28 69 66 20 28 61 6e 64 20 6c 69 6d (if (and lim
20a0: 69 74 0a 09 09 09 20 20 20 20 20 28 3e 20 28 6c it.... (> (l
20b0: 65 6e 67 74 68 20 6e 65 77 2d 72 65 73 29 20 6c ength new-res) l
20c0: 69 6d 69 74 29 29 0a 09 09 09 6e 65 77 2d 72 65 imit))....new-re
20d0: 73 20 3b 3b 20 28 74 61 6b 65 20 6e 65 77 2d 72 s ;; (take new-r
20e0: 65 73 20 6c 69 6d 69 74 29 20 20 3c 3d 20 6e 65 es limit) <= ne
20f0: 65 64 20 69 6e 74 65 6c 6c 69 67 65 6e 74 20 73 ed intelligent s
2100: 6f 72 74 69 6e 67 20 62 65 66 6f 72 65 20 74 68 orting before th
2110: 69 73 20 77 69 6c 6c 20 77 6f 72 6b 0a 09 09 09 is will work....
2120: 6e 65 77 2d 72 65 73 29 0a 09 09 20 20 20 20 28 new-res)... (
2130: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
2140: 64 72 20 74 61 6c 29 20 6e 65 77 2d 72 65 73 29 dr tal) new-res)
2150: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
2160: 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6e 75 e (server:get-nu
2170: 6d 2d 61 6c 69 76 65 20 73 72 76 6c 73 74 29 0a m-alive srvlst).
2180: 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 61 6c 69 (let ((num-ali
2190: 76 65 20 30 29 29 0a 20 20 20 20 28 66 6f 72 2d ve 0)). (for-
21a0: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
21b0: 61 20 28 73 65 72 76 65 72 29 0a 20 20 20 20 20 a (server).
21c0: 20 20 28 6d 61 74 63 68 2d 6c 65 74 20 28 28 28 (match-let (((
21d0: 6d 6f 64 2d 74 69 6d 65 20 68 6f 73 74 20 70 6f mod-time host po
21e0: 72 74 20 73 74 61 72 74 2d 74 69 6d 65 20 70 69 rt start-time pi
21f0: 64 29 0a 09 09 20 20 20 20 73 65 72 76 65 72 29 d)... server)
2200: 29 0a 09 20 28 6c 65 74 2a 20 28 28 75 70 74 69 ).. (let* ((upti
2210: 6d 65 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d me (- (current-
2220: 73 65 63 6f 6e 64 73 29 20 6d 6f 64 2d 74 69 6d seconds) mod-tim
2230: 65 29 29 0a 09 09 28 72 75 6e 74 69 6d 65 20 28 e))...(runtime (
2240: 69 66 20 73 74 61 72 74 2d 74 69 6d 65 0a 09 09 if start-time...
2250: 09 20 20 20 20 20 28 2d 20 6d 6f 64 2d 74 69 6d . (- mod-tim
2260: 65 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 09 09 e start-time)...
2270: 09 20 20 20 20 20 30 29 29 29 0a 09 20 20 20 28 . 0))).. (
2280: 69 66 20 28 3c 20 75 70 74 69 6d 65 20 35 29 28 if (< uptime 5)(
2290: 73 65 74 21 20 6e 75 6d 2d 61 6c 69 76 65 20 28 set! num-alive (
22a0: 2b 20 6e 75 6d 2d 61 6c 69 76 65 20 31 29 29 29 + num-alive 1)))
22b0: 29 29 29 0a 20 20 20 20 20 73 72 76 6c 73 74 29 ))). srvlst)
22c0: 0a 20 20 20 20 6e 75 6d 2d 61 6c 69 76 65 29 29 . num-alive))
22d0: 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 20 6c 69 73 ..;; given a lis
22e0: 74 20 6f 66 20 73 65 72 76 65 72 73 20 67 65 74 t of servers get
22f0: 20 61 20 6c 69 73 74 20 6f 66 20 76 61 6c 69 64 a list of valid
2300: 20 73 65 72 76 65 72 73 2c 20 69 2e 65 2e 20 61 servers, i.e. a
2310: 74 20 6c 65 61 73 74 0a 3b 3b 20 31 30 20 73 65 t least.;; 10 se
2320: 63 6f 6e 64 73 20 6f 6c 64 2c 20 68 61 73 20 73 conds old, has s
2330: 74 61 72 74 65 64 20 61 6e 64 20 69 73 20 6c 65 tarted and is le
2340: 73 73 20 74 68 61 6e 20 31 20 68 6f 75 72 20 6f ss than 1 hour o
2350: 6c 64 20 61 6e 64 20 69 73 0a 3b 3b 20 61 63 74 ld and is.;; act
2360: 69 76 65 20 28 69 2e 65 2e 20 6d 6f 64 2d 74 69 ive (i.e. mod-ti
2370: 6d 65 20 3c 20 31 30 20 73 65 63 6f 6e 64 73 0a me < 10 seconds.
2380: 3b 3b 0a 3b 3b 20 6d 6f 64 2d 74 69 6d 65 20 68 ;;.;; mod-time h
2390: 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 2d 74 ost port start-t
23a0: 69 6d 65 20 70 69 64 0a 3b 3b 0a 3b 3b 20 73 6f ime pid.;;.;; so
23b0: 72 74 20 62 79 20 73 74 61 72 74 2d 74 69 6d 65 rt by start-time
23c0: 20 64 65 73 63 65 6e 64 69 6e 67 2e 20 49 2e 65 descending. I.e
23d0: 2e 20 67 65 74 20 74 68 65 20 6f 6c 64 65 73 74 . get the oldest
23e0: 20 66 69 72 73 74 2e 20 59 6f 75 6e 67 20 73 65 first. Young se
23f0: 72 76 65 72 73 20 77 69 6c 6c 20 74 68 75 73 20 rvers will thus
2400: 64 72 6f 70 20 6f 66 66 0a 3b 3b 20 61 6e 64 20 drop off.;; and
2410: 73 65 72 76 65 72 73 20 73 68 6f 75 6c 64 20 73 servers should s
2420: 74 69 63 6b 20 61 72 6f 75 6e 64 20 66 6f 72 20 tick around for
2430: 61 62 6f 75 74 20 74 77 6f 20 68 6f 75 72 73 20 about two hours
2440: 6f 72 20 73 6f 2e 0a 3b 3b 0a 28 64 65 66 69 6e or so..;;.(defin
2450: 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 e (server:get-be
2460: 73 74 20 73 72 76 6c 73 74 29 0a 20 20 28 6c 65 st srvlst). (le
2470: 74 2a 20 28 28 6e 75 6d 73 20 28 73 65 72 76 65 t* ((nums (serve
2480: 72 3a 67 65 74 2d 6e 75 6d 2d 73 65 72 76 65 72 r:get-num-server
2490: 73 29 29 0a 09 20 28 6e 6f 77 20 20 28 63 75 72 s)).. (now (cur
24a0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
24b0: 20 28 73 6c 73 74 20 28 73 6f 72 74 0a 09 09 28 (slst (sort...(
24c0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
24d0: 72 65 63 29 0a 09 09 09 20 20 28 69 66 20 28 61 rec).... (if (a
24e0: 6e 64 20 28 6c 69 73 74 3f 20 72 65 63 29 0a 09 nd (list? rec)..
24f0: 09 09 09 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 ... (> (length
2500: 20 72 65 63 29 20 32 29 29 0a 09 09 09 20 20 20 rec) 2))....
2510: 20 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 2d (let ((start-
2520: 74 69 6d 65 20 28 6c 69 73 74 2d 72 65 66 20 72 time (list-ref r
2530: 65 63 20 33 29 29 0a 09 09 09 09 20 20 20 20 28 ec 3))..... (
2540: 6d 6f 64 2d 74 69 6d 65 20 20 20 28 6c 69 73 74 mod-time (list
2550: 2d 72 65 66 20 72 65 63 20 30 29 29 29 0a 09 09 -ref rec 0)))...
2560: 09 09 3b 3b 20 28 70 72 69 6e 74 20 22 73 74 61 ..;; (print "sta
2570: 72 74 2d 74 69 6d 65 3a 20 22 20 73 74 61 72 74 rt-time: " start
2580: 2d 74 69 6d 65 20 22 20 6d 6f 64 2d 74 69 6d 65 -time " mod-time
2590: 3a 20 22 20 6d 6f 64 2d 74 69 6d 65 29 0a 09 09 : " mod-time)...
25a0: 09 09 28 61 6e 64 20 73 74 61 72 74 2d 74 69 6d ..(and start-tim
25b0: 65 20 6d 6f 64 2d 74 69 6d 65 0a 09 09 09 09 20 e mod-time.....
25c0: 20 20 20 20 28 3e 20 28 2d 20 6e 6f 77 20 73 74 (> (- now st
25d0: 61 72 74 2d 74 69 6d 65 29 20 30 29 20 20 20 20 art-time) 0)
25e0: 3b 3b 20 62 65 65 6e 20 72 75 6e 6e 69 6e 67 20 ;; been running
25f0: 61 74 20 6c 65 61 73 74 20 30 20 73 65 63 6f 6e at least 0 secon
2600: 64 73 0a 09 09 09 09 20 20 20 20 20 28 3c 20 28 ds..... (< (
2610: 2d 20 6e 6f 77 20 6d 6f 64 2d 74 69 6d 65 29 20 - now mod-time)
2620: 20 20 31 36 29 20 20 20 3b 3b 20 73 74 69 6c 6c 16) ;; still
2630: 20 61 6c 69 76 65 20 2d 20 66 69 6c 65 20 74 6f alive - file to
2640: 75 63 68 65 64 20 69 6e 20 6c 61 73 74 20 31 36 uched in last 16
2650: 20 73 65 63 6f 6e 64 73 0a 09 09 09 09 20 20 20 seconds.....
2660: 20 20 28 3c 20 28 2d 20 6e 6f 77 20 73 74 61 72 (< (- now star
2670: 74 2d 74 69 6d 65 29 20 20 20 20 20 20 20 0a 09 t-time) ..
2680: 09 09 09 09 28 2b 20 28 2d 20 28 73 74 72 69 6e ....(+ (- (strin
2690: 67 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 g->number (or (c
26a0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
26b0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 onfigdat* "serve
26c0: 72 22 20 22 72 75 6e 74 69 6d 65 22 29 20 22 33 r" "runtime") "3
26d0: 36 30 30 22 29 29 0a 09 09 09 09 09 20 20 20 20 600"))......
26e0: 20 20 31 38 30 29 0a 09 09 09 09 09 20 20 20 28 180)...... (
26f0: 72 61 6e 64 6f 6d 20 33 36 30 29 29 29 20 3b 3b random 360))) ;;
2700: 20 75 6e 64 65 72 20 6f 6e 65 20 68 6f 75 72 20 under one hour
2710: 72 75 6e 6e 69 6e 67 20 74 69 6d 65 20 2b 2f 2d running time +/-
2720: 20 31 38 30 0a 09 09 09 09 20 20 20 20 20 29 29 180..... ))
2730: 0a 09 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 .... #f))..
2740: 09 09 73 72 76 6c 73 74 29 0a 09 09 28 6c 61 6d ..srvlst)...(lam
2750: 62 64 61 20 28 61 20 62 29 0a 09 09 20 20 28 3c bda (a b)... (<
2760: 20 28 6c 69 73 74 2d 72 65 66 20 61 20 33 29 0a (list-ref a 3).
2770: 09 09 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 .. (list-ref
2780: 20 62 20 33 29 29 29 29 29 29 0a 20 20 20 20 28 b 3)))))). (
2790: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 6c if (> (length sl
27a0: 73 74 29 20 6e 75 6d 73 29 0a 09 28 74 61 6b 65 st) nums)..(take
27b0: 20 73 6c 73 74 20 6e 75 6d 73 29 0a 09 73 6c 73 slst nums)..sls
27c0: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 t)))..(define (s
27d0: 65 72 76 65 72 3a 67 65 74 2d 66 69 72 73 74 2d erver:get-first-
27e0: 62 65 73 74 20 61 72 65 61 70 61 74 68 29 0a 20 best areapath).
27f0: 20 28 6c 65 74 20 28 28 73 72 76 72 73 20 28 73 (let ((srvrs (s
2800: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 20 28 erver:get-best (
2810: 73 65 72 76 65 72 3a 67 65 74 2d 6c 69 73 74 20 server:get-list
2820: 61 72 65 61 70 61 74 68 29 29 29 29 0a 20 20 20 areapath)))).
2830: 20 28 69 66 20 28 61 6e 64 20 73 72 76 72 73 0a (if (and srvrs.
2840: 09 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c . (not (null
2850: 3f 20 73 72 76 72 73 29 29 29 0a 09 28 63 61 72 ? srvrs)))..(car
2860: 20 73 72 76 72 73 29 0a 09 23 66 29 29 29 0a 0a srvrs)..#f)))..
2870: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
2880: 67 65 74 2d 72 61 6e 64 2d 62 65 73 74 20 61 72 get-rand-best ar
2890: 65 61 70 61 74 68 29 0a 20 20 28 6c 65 74 20 28 eapath). (let (
28a0: 28 73 72 76 72 73 20 28 73 65 72 76 65 72 3a 67 (srvrs (server:g
28b0: 65 74 2d 62 65 73 74 20 28 73 65 72 76 65 72 3a et-best (server:
28c0: 67 65 74 2d 6c 69 73 74 20 61 72 65 61 70 61 74 get-list areapat
28d0: 68 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 h)))). (if (a
28e0: 6e 64 20 28 6c 69 73 74 3f 20 73 72 76 72 73 29 nd (list? srvrs)
28f0: 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c .. (not (nul
2900: 6c 3f 20 73 72 76 72 73 29 29 29 0a 09 28 6c 65 l? srvrs)))..(le
2910: 74 2a 20 28 28 6c 65 6e 20 28 6c 65 6e 67 74 68 t* ((len (length
2920: 20 73 72 76 72 73 29 29 0a 09 20 20 20 20 20 20 srvrs))..
2930: 20 28 69 64 78 20 28 72 61 6e 64 6f 6d 20 6c 65 (idx (random le
2940: 6e 29 29 29 0a 09 20 20 28 6c 69 73 74 2d 72 65 n))).. (list-re
2950: 66 20 73 72 76 72 73 20 69 64 78 29 29 0a 09 23 f srvrs idx))..#
2960: 66 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 f)))...(define (
2970: 73 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e 75 server:record->u
2980: 72 6c 20 73 65 72 76 72 29 0a 20 20 28 6d 61 74 rl servr). (mat
2990: 63 68 2d 6c 65 74 20 28 28 28 6d 6f 64 2d 74 69 ch-let (((mod-ti
29a0: 6d 65 20 68 6f 73 74 20 70 6f 72 74 20 73 74 61 me host port sta
29b0: 72 74 2d 74 69 6d 65 20 70 69 64 29 0a 09 20 20 rt-time pid)..
29c0: 20 20 20 20 20 73 65 72 76 72 29 29 0a 20 20 20 servr)).
29d0: 20 28 69 66 20 28 61 6e 64 20 68 6f 73 74 20 70 (if (and host p
29e0: 6f 72 74 29 0a 09 28 63 6f 6e 63 20 68 6f 73 74 ort)..(conc host
29f0: 20 22 3a 22 20 70 6f 72 74 29 0a 09 23 66 29 29 ":" port)..#f))
2a00: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 )..(define (serv
2a10: 65 72 3a 67 65 74 2d 63 6c 69 65 6e 74 2d 73 69 er:get-client-si
2a20: 67 6e 61 74 75 72 65 29 20 3b 3b 20 42 42 3e 20 gnature) ;; BB>
2a30: 77 68 79 20 69 73 20 74 68 69 73 20 70 72 6f 63 why is this proc
2a40: 20 6e 61 6d 65 64 20 22 67 65 74 2d 22 3f 20 20 named "get-"?
2a50: 69 74 20 72 65 74 75 72 6e 73 20 6e 6f 74 68 69 it returns nothi
2a60: 6e 67 20 2d 2d 20 73 65 74 21 20 68 61 73 20 6e ng -- set! has n
2a70: 6f 74 20 72 65 74 75 72 6e 20 76 61 6c 75 65 2e ot return value.
2a80: 0a 20 20 28 69 66 20 2a 6d 79 2d 63 6c 69 65 6e . (if *my-clien
2a90: 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 2a 6d 79 t-signature* *my
2aa0: 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 -client-signatur
2ab0: 65 2a 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 e*. (let ((
2ac0: 73 69 67 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 sig (server:mk-s
2ad0: 69 67 6e 61 74 75 72 65 29 29 29 0a 20 20 20 20 ignature))).
2ae0: 20 20 20 20 28 73 65 74 21 20 2a 6d 79 2d 63 6c (set! *my-cl
2af0: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 ient-signature*
2b00: 73 69 67 29 0a 20 20 20 20 20 20 20 20 2a 6d 79 sig). *my
2b10: 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 -client-signatur
2b20: 65 2a 29 29 29 0a 0a 3b 3b 20 6b 69 6e 64 20 73 e*)))..;; kind s
2b30: 74 61 72 74 20 75 70 20 6f 66 20 73 65 72 76 65 tart up of serve
2b40: 72 73 2c 20 77 61 69 74 20 34 30 20 73 65 63 6f rs, wait 40 seco
2b50: 6e 64 73 20 62 65 66 6f 72 65 20 61 6c 6c 6f 77 nds before allow
2b60: 69 6e 67 20 61 6e 6f 74 68 65 72 20 73 65 72 76 ing another serv
2b70: 65 72 20 66 6f 72 20 61 20 67 69 76 65 6e 0a 3b er for a given.;
2b80: 3b 20 72 75 6e 2d 69 64 20 74 6f 20 62 65 20 6c ; run-id to be l
2b90: 61 75 6e 63 68 65 64 0a 28 64 65 66 69 6e 65 20 aunched.(define
2ba0: 28 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e (server:kind-run
2bb0: 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 69 66 areapath). (if
2bc0: 20 28 6e 6f 74 20 28 73 65 72 76 65 72 3a 63 68 (not (server:ch
2bd0: 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 eck-if-running a
2be0: 72 65 61 70 61 74 68 29 29 20 3b 3b 20 77 68 79 reapath)) ;; why
2bf0: 20 74 72 79 20 69 66 20 74 68 65 72 65 20 69 73 try if there is
2c00: 20 61 6c 72 65 61 64 79 20 61 20 73 65 72 76 65 already a serve
2c10: 72 20 72 75 6e 6e 69 6e 67 3f 0a 20 20 20 20 20 r running?.
2c20: 20 28 6c 65 74 2a 20 28 28 6c 61 73 74 2d 72 75 (let* ((last-ru
2c30: 6e 2d 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c n-dat (hash-tabl
2c40: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 e-ref/default *s
2c50: 65 72 76 65 72 2d 6b 69 6e 64 2d 72 75 6e 2a 20 erver-kind-run*
2c60: 61 72 65 61 70 61 74 68 20 27 28 30 20 30 29 29 areapath '(0 0))
2c70: 29 20 3b 3b 20 63 61 6c 6c 6e 75 6d 2c 20 77 68 ) ;; callnum, wh
2c80: 65 6e 72 75 6e 0a 09 20 20 20 20 20 28 63 61 6c enrun.. (cal
2c90: 6c 2d 6e 75 6d 20 20 20 20 20 28 63 61 72 20 6c l-num (car l
2ca0: 61 73 74 2d 72 75 6e 2d 64 61 74 29 29 0a 09 20 ast-run-dat))..
2cb0: 20 20 20 20 28 77 68 65 6e 2d 72 75 6e 20 20 20 (when-run
2cc0: 20 20 28 63 61 64 72 20 6c 61 73 74 2d 72 75 6e (cadr last-run
2cd0: 2d 64 61 74 29 29 0a 09 20 20 20 20 20 28 72 75 -dat)).. (ru
2ce0: 6e 2d 64 65 6c 61 79 20 20 20 20 28 2b 20 28 63 n-delay (+ (c
2cf0: 61 73 65 20 63 61 6c 6c 2d 6e 75 6d 0a 09 09 09 ase call-num....
2d00: 09 28 28 30 29 20 20 20 20 30 29 0a 09 09 09 09 .((0) 0).....
2d10: 28 28 31 29 20 20 20 32 30 29 0a 09 09 09 09 28 ((1) 20).....(
2d20: 28 32 29 20 20 33 30 30 29 0a 09 09 09 09 28 65 (2) 300).....(e
2d30: 6c 73 65 20 36 30 30 29 29 0a 09 09 09 20 20 20 lse 600))....
2d40: 20 20 20 28 72 61 6e 64 6f 6d 20 35 29 29 29 20 (random 5)))
2d50: 20 20 3b 3b 20 61 64 64 20 61 20 73 6d 61 6c 6c ;; add a small
2d60: 20 72 61 6e 64 6f 6d 20 6e 75 6d 62 65 72 20 6a random number j
2d70: 75 73 74 20 69 6e 20 63 61 73 65 20 61 20 6c 6f ust in case a lo
2d80: 74 20 6f 66 20 6a 6f 62 73 20 68 69 74 20 74 68 t of jobs hit th
2d90: 65 20 77 6f 72 6b 20 68 6f 73 74 73 20 73 69 6d e work hosts sim
2da0: 75 6c 74 61 6e 65 6f 75 73 6c 79 0a 09 20 20 20 ultaneously..
2db0: 20 20 28 6c 6f 63 6b 2d 66 69 6c 65 20 20 20 20 (lock-file
2dc0: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 (conc areapath "
2dd0: 2f 6c 6f 67 73 2f 73 65 72 76 65 72 2d 73 74 61 /logs/server-sta
2de0: 72 74 2e 6c 6f 63 6b 22 29 29 29 0a 09 28 69 66 rt.lock")))..(if
2df0: 09 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d .(> (- (current-
2e00: 73 65 63 6f 6e 64 73 29 20 77 68 65 6e 2d 72 75 seconds) when-ru
2e10: 6e 29 20 72 75 6e 2d 64 65 6c 61 79 29 0a 09 09 n) run-delay)...
2e20: 28 62 65 67 69 6e 0a 09 09 20 20 28 63 6f 6d 6d (begin... (comm
2e30: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c on:simple-file-l
2e40: 6f 63 6b 2d 61 6e 64 2d 77 61 69 74 20 6c 6f 63 ock-and-wait loc
2e50: 6b 2d 66 69 6c 65 20 65 78 70 69 72 65 2d 74 69 k-file expire-ti
2e60: 6d 65 3a 20 31 35 29 0a 09 09 20 20 28 73 65 72 me: 15)... (ser
2e70: 76 65 72 3a 72 75 6e 20 61 72 65 61 70 61 74 68 ver:run areapath
2e80: 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c )... (thread-sl
2e90: 65 65 70 21 20 32 29 20 3b 3b 20 64 6f 6e 27 74 eep! 2) ;; don't
2ea0: 20 72 65 6c 65 61 73 65 20 74 68 65 20 6c 6f 63 release the loc
2eb0: 6b 20 66 6f 72 20 61 74 20 6c 65 61 73 74 20 61 k for at least a
2ec0: 20 66 65 77 20 73 65 63 6f 6e 64 73 0a 09 09 20 few seconds...
2ed0: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
2ee0: 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 file-release-loc
2ef0: 6b 20 6c 6f 63 6b 2d 66 69 6c 65 29 29 29 0a 09 k lock-file)))..
2f00: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
2f10: 20 2a 73 65 72 76 65 72 2d 6b 69 6e 64 2d 72 75 *server-kind-ru
2f20: 6e 2a 20 61 72 65 61 70 61 74 68 20 28 6c 69 73 n* areapath (lis
2f30: 74 20 28 2b 20 63 61 6c 6c 2d 6e 75 6d 20 31 29 t (+ call-num 1)
2f40: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2f50: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
2f60: 28 73 65 72 76 65 72 3a 73 74 61 72 74 2d 61 6e (server:start-an
2f70: 64 2d 77 61 69 74 20 61 72 65 61 70 61 74 68 20 d-wait areapath
2f80: 23 21 6b 65 79 20 28 74 69 6d 65 6f 75 74 20 36 #!key (timeout 6
2f90: 30 29 29 0a 20 20 28 6c 65 74 20 28 28 67 69 76 0)). (let ((giv
2fa0: 65 2d 75 70 2d 74 69 6d 65 20 28 2b 20 28 63 75 e-up-time (+ (cu
2fb0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 74 rrent-seconds) t
2fc0: 69 6d 65 6f 75 74 29 29 29 0a 20 20 20 20 28 6c imeout))). (l
2fd0: 65 74 20 6c 6f 6f 70 20 28 28 73 65 72 76 65 72 et loop ((server
2fe0: 2d 75 72 6c 20 28 73 65 72 76 65 72 3a 63 68 65 -url (server:che
2ff0: 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 ck-if-running ar
3000: 65 61 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 eapath))..
3010: 20 28 74 72 79 2d 6e 75 6d 20 20 20 20 30 29 29 (try-num 0))
3020: 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 73 . (if (or s
3030: 65 72 76 65 72 2d 75 72 6c 0a 09 20 20 20 20 20 erver-url..
3040: 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (> (current-sec
3050: 6f 6e 64 73 29 20 67 69 76 65 2d 75 70 2d 74 69 onds) give-up-ti
3060: 6d 65 29 29 20 3b 3b 20 73 65 72 76 65 72 2d 75 me)) ;; server-u
3070: 72 6c 20 77 69 6c 6c 20 62 65 20 23 66 20 69 66 rl will be #f if
3080: 20 6e 6f 20 73 65 72 76 65 72 20 61 76 61 69 6c no server avail
3090: 61 62 6c 65 2e 0a 09 20 20 73 65 72 76 65 72 2d able... server-
30a0: 75 72 6c 0a 09 20 20 28 6c 65 74 20 28 28 6e 75 url.. (let ((nu
30b0: 6d 2d 6f 6b 20 28 6c 65 6e 67 74 68 20 28 73 65 m-ok (length (se
30c0: 72 76 65 72 3a 67 65 74 2d 62 65 73 74 20 28 73 rver:get-best (s
30d0: 65 72 76 65 72 3a 67 65 74 2d 6c 69 73 74 20 61 erver:get-list a
30e0: 72 65 61 70 61 74 68 29 29 29 29 29 0a 09 20 20 reapath)))))..
30f0: 20 20 28 69 66 20 28 61 6e 64 20 28 3e 20 74 72 (if (and (> tr
3100: 79 2d 6e 75 6d 20 30 29 20 20 3b 3b 20 66 69 72 y-num 0) ;; fir
3110: 73 74 20 74 69 6d 65 20 74 68 72 6f 75 67 68 20 st time through
3120: 73 69 6d 70 6c 79 20 77 61 69 74 20 61 20 6c 69 simply wait a li
3130: 74 74 6c 65 20 77 68 69 6c 65 20 74 68 65 6e 20 ttle while then
3140: 74 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 try again...
3150: 20 28 3c 20 6e 75 6d 2d 6f 6b 20 31 29 29 20 20 (< num-ok 1))
3160: 3b 3b 20 69 66 20 74 68 65 72 65 20 61 72 65 20 ;; if there are
3170: 6e 6f 20 64 65 63 65 6e 74 20 63 61 6e 64 69 64 no decent candid
3180: 61 74 65 73 20 66 6f 72 20 73 65 72 76 65 72 73 ates for servers
3190: 20 74 68 65 6e 20 74 72 79 20 73 74 61 72 74 69 then try starti
31a0: 6e 67 20 61 20 6e 65 77 20 6f 6e 65 0a 09 09 28 ng a new one...(
31b0: 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 server:kind-run
31c0: 61 72 65 61 70 61 74 68 29 29 0a 09 20 20 20 20 areapath))..
31d0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 (thread-sleep! 5
31e0: 29 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 73 65 ).. (loop (se
31f0: 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 rver:check-if-ru
3200: 6e 6e 69 6e 67 20 61 72 65 61 70 61 74 68 29 0a nning areapath).
3210: 09 09 20 20 28 2b 20 74 72 79 2d 6e 75 6d 20 31 .. (+ try-num 1
3220: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
3230: 20 73 65 72 76 65 72 3a 74 72 79 2d 72 75 6e 6e server:try-runn
3240: 69 6e 67 20 73 65 72 76 65 72 3a 72 75 6e 29 20 ing server:run)
3250: 3b 3b 20 74 68 65 72 65 20 69 73 20 6e 6f 20 6d ;; there is no m
3260: 6f 72 65 20 70 65 72 2d 72 75 6e 20 73 65 72 76 ore per-run serv
3270: 65 72 73 20 3b 3b 20 52 45 4d 4f 56 45 20 4d 45 ers ;; REMOVE ME
3280: 2e 20 42 55 47 2e 0a 0a 28 64 65 66 69 6e 65 20 . BUG...(define
3290: 28 73 65 72 76 65 72 3a 67 65 74 2d 6e 75 6d 2d (server:get-num-
32a0: 73 65 72 76 65 72 73 20 23 21 6b 65 79 20 28 6e servers #!key (n
32b0: 75 6d 73 65 72 76 65 72 73 20 32 29 29 0a 20 20 umservers 2)).
32c0: 28 6c 65 74 20 28 28 6e 73 20 28 73 74 72 69 6e (let ((ns (strin
32d0: 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 20 20 20 20 g->number..
32e0: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
32f0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
3300: 22 73 65 72 76 65 72 22 20 22 6e 75 6d 73 65 72 "server" "numser
3310: 76 65 72 73 22 29 20 22 6e 6f 74 61 6e 75 6d 62 vers") "notanumb
3320: 65 72 22 29 29 29 29 0a 20 20 20 20 28 6f 72 20 er")))). (or
3330: 6e 73 20 6e 75 6d 73 65 72 76 65 72 73 29 29 29 ns numservers)))
3340: 0a 0a 3b 3b 20 6e 6f 20 6c 6f 6e 67 65 72 20 63 ..;; no longer c
3350: 61 72 65 20 69 66 20 6d 75 6c 74 69 70 6c 65 20 are if multiple
3360: 73 65 72 76 65 72 73 20 61 72 65 20 73 74 61 72 servers are star
3370: 74 65 64 20 62 79 20 61 63 63 69 64 65 6e 74 2e ted by accident.
3380: 20 6f 6c 64 65 72 20 73 65 72 76 65 72 73 20 77 older servers w
3390: 69 6c 6c 20 64 72 6f 70 20 6f 66 66 20 69 6e 20 ill drop off in
33a0: 74 69 6d 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 time..;;.(define
33b0: 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 (server:check-i
33c0: 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 61 f-running areapa
33d0: 74 68 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 6e th) ;; #!key (n
33e0: 75 6d 73 65 72 76 65 72 73 20 22 32 22 29 29 0a umservers "2")).
33f0: 20 20 28 6c 65 74 2a 20 28 28 6e 73 20 20 20 20 (let* ((ns
3400: 20 20 20 20 20 20 20 20 28 73 65 72 76 65 72 3a (server:
3410: 67 65 74 2d 6e 75 6d 2d 73 65 72 76 65 72 73 29 get-num-servers)
3420: 29 0a 09 20 28 73 65 72 76 65 72 73 20 20 20 20 ).. (servers
3430: 20 20 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 (server:get-b
3440: 65 73 74 20 28 73 65 72 76 65 72 3a 67 65 74 2d est (server:get-
3450: 6c 69 73 74 20 61 72 65 61 70 61 74 68 29 29 29 list areapath)))
3460: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
3470: 22 73 65 72 76 65 72 73 3a 20 22 20 73 65 72 76 "servers: " serv
3480: 65 72 73 20 22 20 6e 73 3a 20 22 20 6e 73 29 0a ers " ns: " ns).
3490: 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 (if (or (and
34a0: 20 73 65 72 76 65 72 73 0a 09 09 20 28 6e 75 6c servers... (nul
34b0: 6c 3f 20 73 65 72 76 65 72 73 29 29 0a 09 20 20 l? servers))..
34c0: 20 20 28 6e 6f 74 20 73 65 72 76 65 72 73 29 0a (not servers).
34d0: 09 20 20 20 20 28 61 6e 64 20 28 6c 69 73 74 3f . (and (list?
34e0: 20 73 65 72 76 65 72 73 29 0a 09 09 20 28 3c 20 servers)... (<
34f0: 28 6c 65 6e 67 74 68 20 73 65 72 76 65 72 73 29 (length servers)
3500: 20 28 72 61 6e 64 6f 6d 20 6e 73 29 29 29 29 20 (random ns))))
3510: 3b 3b 20 73 6f 6d 65 77 68 65 72 65 20 62 65 74 ;; somewhere bet
3520: 77 65 65 6e 20 30 20 61 6e 64 20 6e 75 6d 73 65 ween 0 and numse
3530: 72 76 65 72 73 0a 20 20 20 20 20 20 20 20 23 66 rvers. #f
3540: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f . (let lo
3550: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 73 65 op ((hed (car se
3560: 72 76 65 72 73 29 29 0a 20 20 20 20 20 20 20 20 rvers)).
3570: 20 20 20 20 20 20 20 20 20 20 20 28 74 61 6c 20 (tal
3580: 28 63 64 72 20 73 65 72 76 65 72 73 29 29 29 0a (cdr servers))).
3590: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
35a0: 28 72 65 73 20 28 73 65 72 76 65 72 3a 63 68 65 (res (server:che
35b0: 63 6b 2d 73 65 72 76 65 72 20 68 65 64 29 29 29 ck-server hed)))
35c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 . (if
35d0: 20 72 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 res.
35e0: 20 20 20 20 20 72 65 73 0a 20 20 20 20 20 20 20 res.
35f0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
3600: 6c 6c 3f 20 74 61 6c 29 0a 20 20 20 20 20 20 20 ll? tal).
3610: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 0a #f.
3620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3630: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
3640: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
3650: 29 29 29 29 0a 0a 3b 3b 20 70 69 6e 67 20 74 68 ))))..;; ping th
3660: 65 20 67 69 76 65 6e 20 73 65 72 76 65 72 0a 3b e given server.;
3670: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 ;.(define (serve
3680: 72 3a 63 68 65 63 6b 2d 73 65 72 76 65 72 20 73 r:check-server s
3690: 65 72 76 65 72 2d 72 65 63 6f 72 64 29 0a 20 20 erver-record).
36a0: 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 75 (let* ((server-u
36b0: 72 6c 20 28 73 65 72 76 65 72 3a 72 65 63 6f 72 rl (server:recor
36c0: 64 2d 3e 75 72 6c 20 73 65 72 76 65 72 2d 72 65 d->url server-re
36d0: 63 6f 72 64 29 29 0a 20 20 20 20 20 20 20 20 20 cord)).
36e0: 28 72 65 73 20 20 20 20 20 20 20 20 28 63 61 73 (res (cas
36f0: 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 e *transport-typ
3700: 65 2a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e*.
3710: 20 20 20 20 20 20 20 20 20 20 28 28 68 74 74 70 ((http
3720: 29 28 73 65 72 76 65 72 3a 70 69 6e 67 20 73 65 )(server:ping se
3730: 72 76 65 72 2d 75 72 6c 29 29 0a 20 20 20 20 20 rver-url)).
3740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3750: 20 20 3b 3b 20 28 28 6e 6d 73 67 29 28 6e 6d 73 ;; ((nmsg)(nms
3760: 67 2d 74 72 61 6e 73 70 6f 72 74 3a 70 69 6e 67 g-transport:ping
3770: 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f (tasks:hostinfo
3780: 2d 67 65 74 2d 69 6e 74 65 72 66 61 63 65 20 73 -get-interface s
3790: 65 72 76 65 72 29 0a 20 20 20 20 20 20 20 20 20 erver).
37a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 ))
37b0: 29 0a 20 20 20 20 28 69 66 20 72 65 73 0a 20 20 ). (if res.
37c0: 20 20 20 20 20 20 73 65 72 76 65 72 2d 75 72 6c server-url
37d0: 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 ..#f)))..(define
37e0: 20 28 73 65 72 76 65 72 3a 6b 69 6c 6c 20 73 65 (server:kill se
37f0: 72 76 72 29 0a 20 20 28 6d 61 74 63 68 2d 6c 65 rvr). (match-le
3800: 74 20 28 28 28 6d 6f 64 2d 74 69 6d 65 20 68 6f t (((mod-time ho
3810: 73 74 6e 61 6d 65 20 70 6f 72 74 20 73 74 61 72 stname port star
3820: 74 2d 74 69 6d 65 20 70 69 64 29 0a 09 20 20 20 t-time pid)..
3830: 20 20 20 20 73 65 72 76 72 29 29 0a 20 20 20 20 servr)).
3840: 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 (tasks:kill-serv
3850: 65 72 20 68 6f 73 74 6e 61 6d 65 20 70 69 64 29 er hostname pid)
3860: 29 29 0a 0a 3b 3b 20 63 61 6c 6c 65 64 20 69 6e ))..;; called in
3870: 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 2c 20 68 megatest.scm, h
3880: 6f 73 74 2d 70 6f 72 74 20 69 73 20 73 74 72 69 ost-port is stri
3890: 6e 67 20 68 6f 73 74 6e 61 6d 65 3a 70 6f 72 74 ng hostname:port
38a0: 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 .;;.;; NOTE: Thi
38b0: 73 20 69 73 20 4e 4f 54 20 63 61 6c 6c 65 64 20 s is NOT called
38c0: 64 69 72 65 63 74 6c 79 20 66 72 6f 6d 20 63 6c directly from cl
38d0: 69 65 6e 74 73 20 61 73 20 6e 6f 74 20 61 6c 6c ients as not all
38e0: 20 74 72 61 6e 73 70 6f 72 74 73 20 73 75 70 70 transports supp
38f0: 6f 72 74 20 61 20 63 6c 69 65 6e 74 20 72 75 6e ort a client run
3900: 6e 69 6e 67 0a 3b 3b 20 20 20 20 20 20 20 69 6e ning.;; in
3910: 20 74 68 65 20 73 61 6d 65 20 70 72 6f 63 65 73 the same proces
3920: 73 20 61 73 20 74 68 65 20 73 65 72 76 65 72 2e s as the server.
3930: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 .;;.(define (ser
3940: 76 65 72 3a 70 69 6e 67 20 68 6f 73 74 2d 70 6f ver:ping host-po
3950: 72 74 2d 69 6e 20 23 21 6b 65 79 20 28 64 6f 2d rt-in #!key (do-
3960: 65 78 69 74 20 23 66 29 29 0a 20 20 28 6c 65 74 exit #f)). (let
3970: 20 28 28 68 6f 73 74 3a 70 6f 72 74 20 28 69 66 ((host:port (if
3980: 20 28 6e 6f 74 20 68 6f 73 74 2d 70 6f 72 74 2d (not host-port-
3990: 69 6e 29 20 3b 3b 20 75 73 65 20 72 65 61 64 2d in) ;; use read-
39a0: 64 6f 74 73 65 72 76 65 72 20 74 6f 20 66 69 6e dotserver to fin
39b0: 64 0a 09 09 20 20 20 20 20 20 20 23 66 20 3b 3b d... #f ;;
39c0: 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 (server:check-i
39d0: 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 f-running *toppa
39e0: 74 68 2a 29 0a 09 09 3b 3b 20 28 69 66 20 28 6e th*)...;; (if (n
39f0: 75 6d 62 65 72 3f 20 68 6f 73 74 2d 70 6f 72 74 umber? host-port
3a00: 2d 69 6e 29 20 3b 3b 20 77 65 20 77 65 72 65 20 -in) ;; we were
3a10: 68 61 6e 64 65 64 20 61 20 73 65 72 76 65 72 2d handed a server-
3a20: 69 64 0a 09 09 3b 3b 20 09 20 20 20 28 6c 65 74 id...;; . (let
3a30: 20 28 28 73 72 65 63 20 28 74 61 73 6b 73 3a 67 ((srec (tasks:g
3a40: 65 74 2d 73 65 72 76 65 72 2d 62 79 2d 69 64 20 et-server-by-id
3a50: 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 (db:delay-if-bus
3a60: 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 y (tasks:open-db
3a70: 29 29 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 )) host-port-in)
3a80: 29 29 0a 09 09 3b 3b 20 09 20 20 20 20 20 3b 3b ))...;; . ;;
3a90: 20 28 70 72 69 6e 74 20 22 73 72 65 63 3a 20 22 (print "srec: "
3aa0: 20 73 72 65 63 20 22 20 68 6f 73 74 2d 70 6f 72 srec " host-por
3ab0: 74 2d 69 6e 3a 20 22 20 68 6f 73 74 2d 70 6f 72 t-in: " host-por
3ac0: 74 2d 69 6e 29 0a 09 09 3b 3b 20 09 20 20 20 20 t-in)...;; .
3ad0: 20 28 69 66 20 73 72 65 63 0a 09 09 3b 3b 20 09 (if srec...;; .
3ae0: 09 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d . (conc (vector-
3af0: 72 65 66 20 73 72 65 63 20 33 29 20 22 3a 22 20 ref srec 3) ":"
3b00: 28 76 65 63 74 6f 72 2d 72 65 66 20 73 72 65 63 (vector-ref srec
3b10: 20 34 29 29 0a 09 09 3b 3b 20 09 09 20 28 63 6f 4))...;; .. (co
3b20: 6e 63 20 22 6e 6f 20 73 75 63 68 20 73 65 72 76 nc "no such serv
3b30: 65 72 2d 69 64 20 22 20 68 6f 73 74 2d 70 6f 72 er-id " host-por
3b40: 74 2d 69 6e 29 29 29 0a 09 09 20 20 20 20 20 20 t-in)))...
3b50: 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 29 29 host-port-in)))
3b60: 20 3b 3b 20 29 0a 20 20 20 20 28 6c 65 74 2a 20 ;; ). (let*
3b70: 28 28 68 6f 73 74 2d 70 6f 72 74 20 28 69 66 20 ((host-port (if
3b80: 68 6f 73 74 3a 70 6f 72 74 0a 09 09 09 20 20 28 host:port.... (
3b90: 6c 65 74 20 28 28 73 6c 73 74 20 28 73 74 72 69 let ((slst (stri
3ba0: 6e 67 2d 73 70 6c 69 74 20 20 20 68 6f 73 74 3a ng-split host:
3bb0: 70 6f 72 74 20 22 3a 22 29 29 29 0a 09 09 09 20 port ":")))....
3bc0: 20 20 20 28 69 66 20 28 65 71 3f 20 28 6c 65 6e (if (eq? (len
3bd0: 67 74 68 20 73 6c 73 74 29 20 32 29 0a 09 09 09 gth slst) 2)....
3be0: 09 28 6c 69 73 74 20 28 63 61 72 20 73 6c 73 74 .(list (car slst
3bf0: 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 )(string->number
3c00: 20 28 63 61 64 72 20 73 6c 73 74 29 29 29 0a 09 (cadr slst)))..
3c10: 09 09 09 23 66 29 29 0a 09 09 09 20 20 23 66 29 ...#f)).... #f)
3c20: 29 29 0a 3b 3b 09 20 20 20 28 74 6f 70 70 61 74 )).;;. (toppat
3c30: 68 20 20 20 20 20 20 20 28 6c 61 75 6e 63 68 3a h (launch:
3c40: 73 65 74 75 70 29 29 29 0a 20 20 20 20 20 20 3b setup))). ;
3c50: 3b 20 28 70 72 69 6e 74 20 22 68 6f 73 74 2d 70 ; (print "host-p
3c60: 6f 72 74 3d 22 20 68 6f 73 74 2d 70 6f 72 74 29 ort=" host-port)
3c70: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
3c80: 68 6f 73 74 2d 70 6f 72 74 29 0a 09 20 20 28 62 host-port).. (b
3c90: 65 67 69 6e 0a 09 20 20 20 20 28 69 66 20 68 6f egin.. (if ho
3ca0: 73 74 2d 70 6f 72 74 2d 69 6e 0a 09 09 28 64 65 st-port-in...(de
3cb0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3cc0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
3cd0: 22 45 52 52 4f 52 3a 20 62 61 64 20 68 6f 73 74 "ERROR: bad host
3ce0: 3a 70 6f 72 74 22 29 29 0a 09 20 20 20 20 28 69 :port")).. (i
3cf0: 66 20 64 6f 2d 65 78 69 74 20 28 65 78 69 74 20 f do-exit (exit
3d00: 31 29 29 0a 09 20 20 20 20 23 66 29 0a 09 20 20 1)).. #f)..
3d10: 28 6c 65 74 2a 20 28 28 69 66 61 63 65 20 20 20 (let* ((iface
3d20: 20 20 20 28 63 61 72 20 68 6f 73 74 2d 70 6f 72 (car host-por
3d30: 74 29 29 0a 09 09 20 28 70 6f 72 74 20 20 20 20 t))... (port
3d40: 20 20 20 28 63 61 64 72 20 68 6f 73 74 2d 70 6f (cadr host-po
3d50: 72 74 29 29 0a 09 09 20 28 73 65 72 76 65 72 2d rt))... (server-
3d60: 64 61 74 20 28 68 74 74 70 2d 74 72 61 6e 73 70 dat (http-transp
3d70: 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 ort:client-conne
3d80: 63 74 20 69 66 61 63 65 20 70 6f 72 74 29 29 0a ct iface port)).
3d90: 09 09 20 28 6c 6f 67 69 6e 2d 72 65 73 20 20 28 .. (login-res (
3da0: 72 6d 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 rmt:login-no-aut
3db0: 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 73 o-client-setup s
3dc0: 65 72 76 65 72 2d 64 61 74 29 29 29 0a 09 20 20 erver-dat)))..
3dd0: 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 (if (and (list
3de0: 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 0a 09 09 20 ? login-res)...
3df0: 20 20 20 20 28 63 61 72 20 6c 6f 67 69 6e 2d 72 (car login-r
3e00: 65 73 29 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 es))...(begin...
3e10: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 4c 4f 47 ;; (print "LOG
3e20: 49 4e 5f 4f 4b 22 29 0a 09 09 20 20 28 69 66 20 IN_OK")... (if
3e30: 64 6f 2d 65 78 69 74 20 28 65 78 69 74 20 30 29 do-exit (exit 0)
3e40: 29 0a 09 09 20 20 23 74 29 0a 09 09 28 62 65 67 )... #t)...(beg
3e50: 69 6e 0a 09 09 20 20 3b 3b 20 28 70 72 69 6e 74 in... ;; (print
3e60: 20 22 4c 4f 47 49 4e 5f 46 41 49 4c 45 44 22 29 "LOGIN_FAILED")
3e70: 0a 09 09 20 20 28 69 66 20 64 6f 2d 65 78 69 74 ... (if do-exit
3e80: 20 28 65 78 69 74 20 31 29 29 0a 09 09 20 20 23 (exit 1))... #
3e90: 66 29 29 29 29 29 29 29 0a 0a 3b 3b 20 72 75 6e f)))))))..;; run
3ea0: 20 70 69 6e 67 20 69 6e 20 73 65 70 61 72 61 74 ping in separat
3eb0: 65 20 70 72 6f 63 65 73 73 2c 20 73 61 66 65 73 e process, safes
3ec0: 74 20 77 61 79 20 69 6e 20 73 6f 6d 65 20 63 61 t way in some ca
3ed0: 73 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ses.;;.(define (
3ee0: 73 65 72 76 65 72 3a 70 69 6e 67 2d 73 65 72 76 server:ping-serv
3ef0: 65 72 20 69 66 61 63 65 70 6f 72 74 29 0a 20 20 er ifaceport).
3f00: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
3f10: 2d 70 69 70 65 20 0a 20 20 20 28 63 6f 6e 63 20 -pipe . (conc
3f20: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 (common:get-mega
3f30: 74 65 73 74 2d 65 78 65 29 20 22 20 2d 70 69 6e test-exe) " -pin
3f40: 67 20 22 20 69 66 61 63 65 70 6f 72 74 29 0a 20 g " ifaceport).
3f50: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
3f60: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e (let loop ((in
3f70: 6c 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 09 l (read-line))..
3f80: 09 28 72 65 73 20 22 4e 4f 52 45 50 4c 59 22 29 .(res "NOREPLY")
3f90: 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 65 6f ). (if (eo
3fa0: 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 f-object? inl)..
3fb0: 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 (case (string
3fc0: 2d 3e 73 79 6d 62 6f 6c 20 72 65 73 29 0a 09 20 ->symbol res)..
3fd0: 20 20 20 20 28 28 4e 4f 52 45 50 4c 59 29 20 20 ((NOREPLY)
3fe0: 23 66 29 0a 09 20 20 20 20 20 28 28 4c 4f 47 49 #f).. ((LOGI
3ff0: 4e 5f 4f 4b 29 20 23 74 29 0a 09 20 20 20 20 20 N_OK) #t)..
4000: 28 65 6c 73 65 20 20 20 20 20 20 20 23 66 29 29 (else #f))
4010: 0a 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 .. (loop (read
4020: 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 29 29 29 -line) inl))))))
4030: 0a 0a 3b 3b 20 4e 4f 54 20 55 53 45 44 20 28 77 ..;; NOT USED (w
4040: 65 6c 6c 2c 20 6f 6b 2c 20 77 61 73 20 72 65 66 ell, ok, was ref
4050: 65 72 65 6e 63 65 64 20 69 6e 20 72 70 63 2d 74 erenced in rpc-t
4060: 72 61 6e 73 70 6f 72 74 20 62 75 74 20 6f 74 68 ransport but oth
4070: 65 72 77 69 73 65 0a 3b 3b 20 6e 6f 74 20 75 73 erwise.;; not us
4080: 65 64 29 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ed)..;;.(define
4090: 28 73 65 72 76 65 72 3a 6c 6f 67 69 6e 20 74 6f (server:login to
40a0: 70 70 61 74 68 29 0a 20 20 28 6c 61 6d 62 64 61 ppath). (lambda
40b0: 20 28 74 6f 70 70 61 74 68 29 0a 20 20 20 20 28 (toppath). (
40c0: 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 set! *db-last-ac
40d0: 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 cess* (current-s
40e0: 65 63 6f 6e 64 73 29 29 20 3b 3b 20 6d 69 67 68 econds)) ;; migh
40f0: 74 20 6e 6f 74 20 62 65 20 6e 65 65 64 65 64 2e t not be needed.
4100: 0a 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f . (if (equal?
4110: 20 2a 74 6f 70 70 61 74 68 2a 20 74 6f 70 70 61 *toppath* toppa
4120: 74 68 29 0a 09 23 74 0a 09 23 66 29 29 29 0a 0a th)..#t..#f)))..
4130: 3b 3b 20 74 69 6d 65 6f 75 74 20 69 73 20 68 6d ;; timeout is hm
4140: 73 20 73 74 72 69 6e 67 3a 20 31 68 20 35 6d 20 s string: 1h 5m
4150: 33 73 2c 20 64 65 66 61 75 6c 74 20 69 73 20 31 3s, default is 1
4160: 20 6d 69 6e 75 74 65 0a 3b 3b 0a 28 64 65 66 69 minute.;;.(defi
4170: 6e 65 20 28 73 65 72 76 65 72 3a 65 78 70 69 72 ne (server:expir
4180: 61 74 69 6f 6e 2d 74 69 6d 65 6f 75 74 29 0a 20 ation-timeout).
4190: 20 28 6c 65 74 20 28 28 74 6d 6f 20 28 63 6f 6e (let ((tmo (con
41a0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
41b0: 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 figdat* "server"
41c0: 20 22 74 69 6d 65 6f 75 74 22 29 29 29 0a 20 20 "timeout"))).
41d0: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
41e0: 6e 67 3f 20 74 6d 6f 29 0a 09 20 20 20 20 20 28 ng? tmo).. (
41f0: 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 72 69 6e common:hms-strin
4200: 67 2d 3e 73 65 63 6f 6e 64 73 20 74 6d 6f 29 29 g->seconds tmo))
4210: 20 3b 3b 20 42 55 47 3a 20 68 6d 73 2d 73 74 72 ;; BUG: hms-str
4220: 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 69 73 20 ing->seconds is
4230: 62 72 6f 6b 65 6e 2c 20 69 66 20 67 69 76 65 6e broken, if given
4240: 20 22 31 30 22 20 72 65 74 75 72 6e 73 20 30 2e "10" returns 0.
4250: 20 41 6c 73 6f 2c 20 69 74 20 64 6f 65 73 6e 27 Also, it doesn'
4260: 74 20 62 65 6c 6f 6e 67 20 69 6e 20 74 68 69 73 t belong in this
4270: 20 6c 6f 67 69 63 20 75 6e 6c 65 73 73 20 74 68 logic unless th
4280: 65 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 e string->number
4290: 20 69 73 20 63 68 61 6e 67 65 64 20 62 65 6c 6f is changed belo
42a0: 77 0a 20 20 20 20 20 20 20 20 28 2a 20 33 36 30 w. (* 360
42b0: 30 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 0 (string->numbe
42c0: 72 20 74 6d 6f 29 29 0a 09 36 30 29 29 29 0a 0a r tmo))..60)))..
42d0: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
42e0: 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 get-best-guess-a
42f0: 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 ddress hostname)
4300: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
4310: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
4320: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
4330: 61 64 72 29 0a 20 20 20 20 20 20 20 28 69 66 20 adr). (if
4340: 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 (not (eq? (u8vec
4350: 74 6f 72 2d 72 65 66 20 61 64 72 20 30 29 20 31 tor-ref adr 0) 1
4360: 32 37 29 29 0a 09 20 20 20 28 73 65 74 21 20 72 27)).. (set! r
4370: 65 73 20 61 64 72 29 29 29 0a 20 20 20 20 20 3b es adr))). ;
4380: 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 63 61 6e ; NOTE: This can
4390: 20 66 61 69 6c 20 77 68 65 6e 20 74 68 65 72 65 fail when there
43a0: 20 69 73 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 6f is no mention o
43b0: 66 20 74 68 65 20 68 6f 73 74 20 69 6e 20 2f 65 f the host in /e
43c0: 74 63 2f 68 6f 73 74 73 2e 20 46 49 58 4d 45 0a tc/hosts. FIXME.
43d0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c 69 (vector->li
43e0: 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 st (hostinfo-add
43f0: 72 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d 65 resses (hostname
4400: 2d 3e 68 6f 73 74 69 6e 66 6f 20 68 6f 73 74 6e ->hostinfo hostn
4410: 61 6d 65 29 29 29 29 0a 20 20 20 20 28 73 74 72 ame)))). (str
4420: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
4430: 0a 20 20 20 20 20 28 6d 61 70 20 6e 75 6d 62 65 . (map numbe
4440: 72 2d 3e 73 74 72 69 6e 67 0a 09 20 20 28 75 38 r->string.. (u8
4450: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 20 vector->list..
4460: 20 28 69 66 20 72 65 73 20 72 65 73 20 28 68 6f (if res res (ho
4470: 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e stname->ip hostn
4480: 61 6d 65 29 29 29 29 20 22 2e 22 29 29 29 0a 0a ame)))) ".")))..
4490: 3b 3b 20 28 64 65 66 69 6e 65 20 73 65 72 76 65 ;; (define serve
44a0: 72 3a 73 79 6e 63 2d 6c 6f 63 6b 2d 74 6f 6b 65 r:sync-lock-toke
44b0: 6e 20 22 53 45 52 56 45 52 5f 53 59 4e 43 5f 4c n "SERVER_SYNC_L
44c0: 4f 43 4b 22 29 0a 3b 3b 20 28 64 65 66 69 6e 65 OCK").;; (define
44d0: 20 28 73 65 72 76 65 72 3a 72 65 6c 65 61 73 65 (server:release
44e0: 2d 73 79 6e 63 2d 6c 6f 63 6b 29 0a 3b 3b 20 20 -sync-lock).;;
44f0: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c (db:no-sync-del
4500: 21 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 73 ! *no-sync-db* s
4510: 65 72 76 65 72 3a 73 79 6e 63 2d 6c 6f 63 6b 2d erver:sync-lock-
4520: 74 6f 6b 65 6e 29 29 0a 3b 3b 20 28 64 65 66 69 token)).;; (defi
4530: 6e 65 20 28 73 65 72 76 65 72 3a 68 61 76 65 2d ne (server:have-
4540: 73 79 6e 63 2d 6c 6f 63 6b 3f 29 0a 3b 3b 20 20 sync-lock?).;;
4550: 20 28 6c 65 74 2a 20 28 28 68 61 76 65 2d 6c 6f (let* ((have-lo
4560: 63 6b 2d 70 61 69 72 20 28 64 62 3a 6e 6f 2d 73 ck-pair (db:no-s
4570: 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 2a 6e 6f ync-get-lock *no
4580: 2d 73 79 6e 63 2d 64 62 2a 20 73 65 72 76 65 72 -sync-db* server
4590: 3a 73 79 6e 63 2d 6c 6f 63 6b 2d 74 6f 6b 65 6e :sync-lock-token
45a0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 )).;; (
45b0: 68 61 76 65 2d 6c 6f 63 6b 3f 20 20 20 20 20 28 have-lock? (
45c0: 63 61 72 20 68 61 76 65 2d 6c 6f 63 6b 2d 70 61 car have-lock-pa
45d0: 69 72 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ir)).;;
45e0: 20 28 6c 6f 63 6b 2d 74 69 6d 65 20 20 20 20 20 (lock-time
45f0: 20 28 63 64 72 20 68 61 76 65 2d 6c 6f 63 6b 2d (cdr have-lock-
4600: 70 61 69 72 29 29 0a 3b 3b 20 20 20 20 20 20 20 pair)).;;
4610: 20 20 20 28 6c 6f 63 6b 2d 61 67 65 20 20 20 20 (lock-age
4620: 20 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (- (current-s
4630: 65 63 6f 6e 64 73 29 20 6c 6f 63 6b 2d 74 69 6d econds) lock-tim
4640: 65 29 29 29 0a 3b 3b 20 20 20 20 20 28 63 6f 6e e))).;; (con
4650: 64 0a 3b 3b 20 20 20 20 20 20 28 68 61 76 65 2d d.;; (have-
4660: 6c 6f 63 6b 3f 20 23 74 29 0a 3b 3b 20 20 20 20 lock? #t).;;
4670: 20 20 28 28 3e 6c 6f 63 6b 2d 61 67 65 0a 3b 3b ((>lock-age.;;
4680: 20 20 20 20 20 20 20 20 28 2a 20 33 20 28 63 6f (* 3 (co
4690: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d nfigf:lookup-num
46a0: 62 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 ber *configdat*
46b0: 22 73 65 72 76 65 72 22 20 22 6d 69 6e 69 6d 75 "server" "minimu
46c0: 6d 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 m-intersync-dela
46d0: 79 22 20 64 65 66 61 75 6c 74 3a 20 31 38 30 29 y" default: 180)
46e0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 73 65 72 )).;; (ser
46f0: 76 65 72 3a 72 65 6c 65 61 73 65 2d 73 79 6e 63 ver:release-sync
4700: 2d 6c 6f 63 6b 29 0a 3b 3b 20 20 20 20 20 20 20 -lock).;;
4710: 28 73 65 72 76 65 72 3a 68 61 76 65 2d 73 79 6e (server:have-syn
4720: 63 2d 6c 6f 63 6b 3f 29 29 0a 3b 3b 20 20 20 20 c-lock?)).;;
4730: 20 20 28 65 6c 73 65 20 23 66 29 29 29 29 0a 0a (else #f))))..
4740: 3b 3b 20 6d 6f 76 69 6e 67 20 74 68 69 73 20 68 ;; moving this h
4750: 65 72 65 20 61 73 20 69 74 20 6e 65 65 64 73 20 ere as it needs
4760: 61 63 63 65 73 73 20 74 6f 20 64 62 20 61 6e 64 access to db and
4770: 20 63 61 6e 6e 6f 74 20 62 65 20 69 6e 20 63 6f cannot be in co
4780: 6d 6d 6f 6e 2e 0a 3b 3b 0a 0a 28 64 65 66 69 6e mmon..;;..(defin
4790: 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 72 e (server:get-br
47a0: 75 74 65 66 6f 72 63 65 2d 73 79 6e 63 65 72 20 uteforce-syncer
47b0: 64 62 73 74 72 75 63 74 20 23 21 6b 65 79 20 28 dbstruct #!key (
47c0: 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 6f 75 fork-to-backgrou
47d0: 6e 64 20 23 66 29 20 28 70 65 72 73 69 73 74 2d nd #f) (persist-
47e0: 75 6e 74 69 6c 2d 73 79 6e 63 20 23 66 29 29 0a until-sync #f)).
47f0: 20 20 28 6c 65 74 2a 20 28 28 73 71 6c 69 74 65 (let* ((sqlite
4800: 2d 65 78 65 20 20 20 28 6f 72 20 28 67 65 74 2d -exe (or (get-
4810: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
4820: 61 62 6c 65 20 22 4d 54 5f 53 51 4c 49 54 45 33 able "MT_SQLITE3
4830: 5f 45 58 45 22 29 29 29 20 3b 3b 20 64 65 66 69 _EXE"))) ;; defi
4840: 6e 65 64 20 69 6e 20 63 66 67 2e 73 68 0a 20 20 ned in cfg.sh.
4850: 20 20 20 20 20 20 20 28 73 79 6e 63 2d 6c 6f 67 (sync-log
4860: 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 (or (args:g
4870: 65 74 2d 61 72 67 20 22 2d 73 79 6e 63 2d 6c 6f et-arg "-sync-lo
4880: 67 22 29 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 g") (conc *toppa
4890: 74 68 2a 20 22 2f 6c 6f 67 73 2f 73 79 6e 63 2d th* "/logs/sync-
48a0: 22 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 " (current-proce
48b0: 73 73 2d 69 64 29 20 22 2d 22 20 28 67 65 74 2d ss-id) "-" (get-
48c0: 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2e 6c 6f 67 host-name) ".log
48d0: 22 29 29 29 0a 09 20 28 74 6d 70 2d 61 72 65 61 "))).. (tmp-area
48e0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
48f0: 2d 64 62 2d 74 6d 70 2d 61 72 65 61 20 2a 61 6c -db-tmp-area *al
4900: 6c 64 61 74 2a 29 29 0a 09 20 28 74 6d 70 2d 64 ldat*)).. (tmp-d
4910: 62 20 20 20 20 20 20 20 28 63 6f 6e 63 20 74 6d b (conc tm
4920: 70 2d 61 72 65 61 20 22 2f 6d 65 67 61 74 65 73 p-area "/megates
4930: 74 2e 64 62 22 29 29 0a 09 20 28 73 74 61 67 69 t.db")).. (stagi
4940: 6e 67 2d 66 69 6c 65 20 28 63 6f 6e 63 20 2a 74 ng-file (conc *t
4950: 6f 70 70 61 74 68 2a 20 22 2f 2e 6d 65 67 61 74 oppath* "/.megat
4960: 65 73 74 2e 64 62 22 29 29 0a 09 20 28 6d 74 64 est.db")).. (mtd
4970: 62 66 69 6c 65 20 20 20 20 20 28 63 6f 6e 63 20 bfile (conc
4980: 2a 74 6f 70 70 61 74 68 2a 20 22 2f 6d 65 67 61 *toppath* "/mega
4990: 74 65 73 74 2e 64 62 22 29 29 0a 09 20 28 6c 6f test.db")).. (lo
49a0: 63 6b 66 69 6c 65 20 20 20 20 20 28 63 6f 6d 6d ckfile (comm
49b0: 6f 6e 3a 67 65 74 2d 73 79 6e 63 2d 6c 6f 63 6b on:get-sync-lock
49c0: 2d 66 69 6c 65 70 61 74 68 20 2a 61 6c 6c 64 61 -filepath *allda
49d0: 74 2a 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 t*)). (s
49e0: 79 6e 63 2d 63 6d 64 2d 63 6f 72 65 20 20 20 20 ync-cmd-core
49f0: 20 28 63 6f 6e 63 20 73 71 6c 69 74 65 2d 65 78 (conc sqlite-ex
4a00: 65 22 20 22 20 74 6d 70 2d 64 62 20 22 20 2e 64 e" " tmp-db " .d
4a10: 75 6d 70 20 7c 20 22 73 71 6c 69 74 65 2d 65 78 ump | "sqlite-ex
4a20: 65 22 20 22 20 73 74 61 67 69 6e 67 2d 66 69 6c e" " staging-fil
4a30: 65 20 22 26 3e 22 73 79 6e 63 2d 6c 6f 67 29 29 e "&>"sync-log))
4a40: 0a 20 20 20 20 20 20 20 20 20 28 73 79 6e 63 2d . (sync-
4a50: 63 6d 64 20 20 20 20 20 28 69 66 20 66 6f 72 6b cmd (if fork
4a60: 2d 74 6f 2d 62 61 63 6b 67 72 6f 75 6e 64 20 0a -to-background .
4a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a80: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 (conc
4a90: 20 22 2f 75 73 72 2f 62 69 6e 2f 65 6e 76 20 4e "/usr/bin/env N
4aa0: 42 46 41 4b 45 5f 4c 4f 47 3d 22 2a 74 6f 70 70 BFAKE_LOG="*topp
4ab0: 61 74 68 2a 22 2f 6c 6f 67 73 2f 6c 61 73 74 2d ath*"/logs/last-
4ac0: 73 65 72 76 65 72 2d 73 79 6e 63 2d 22 28 63 75 server-sync-"(cu
4ad0: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
4ae0: 29 22 2e 6c 6f 67 20 6e 62 66 61 6b 65 20 5c 22 )".log nbfake \"
4af0: 22 73 79 6e 63 2d 63 6d 64 2d 63 6f 72 65 22 20 "sync-cmd-core"
4b00: 26 26 20 2f 62 69 6e 2f 6d 76 20 2d 66 20 22 20 && /bin/mv -f "
4b10: 73 74 61 67 69 6e 67 2d 66 69 6c 65 20 22 20 22 staging-file " "
4b20: 20 6d 74 64 62 66 69 6c 65 22 20 5c 22 22 29 0a mtdbfile" \"").
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 73 79 6e 63 2d sync-
4b50: 63 6d 64 2d 63 6f 72 65 29 29 0a 20 20 20 20 20 cmd-core)).
4b60: 20 20 20 20 28 64 65 66 61 75 6c 74 2d 6d 69 6e (default-min
4b70: 2d 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 -intersync-delay
4b80: 20 32 29 0a 09 20 28 6d 69 6e 2d 69 6e 74 65 72 2).. (min-inter
4b90: 73 79 6e 63 2d 64 65 6c 61 79 20 28 63 6f 6e 66 sync-delay (conf
4ba0: 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 65 igf:lookup-numbe
4bb0: 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 r *configdat* "s
4bc0: 65 72 76 65 72 22 20 22 6d 69 6e 69 6d 75 6d 2d erver" "minimum-
4bd0: 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 22 intersync-delay"
4be0: 20 64 65 66 61 75 6c 74 3a 20 64 65 66 61 75 6c default: defaul
4bf0: 74 2d 6d 69 6e 2d 69 6e 74 65 72 73 79 6e 63 2d t-min-intersync-
4c00: 64 65 6c 61 79 29 29 0a 20 20 20 20 20 20 20 20 delay)).
4c10: 20 28 64 65 66 61 75 6c 74 2d 64 75 74 79 2d 63 (default-duty-c
4c20: 79 63 6c 65 20 30 2e 31 29 0a 20 20 20 20 20 20 ycle 0.1).
4c30: 20 20 20 28 64 75 74 79 2d 63 79 63 6c 65 20 20 (duty-cycle
4c40: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
4c50: 2d 6e 75 6d 62 65 72 20 2a 63 6f 6e 66 69 67 64 -number *configd
4c60: 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 73 79 at* "server" "sy
4c70: 6e 63 2d 64 75 74 79 2d 63 79 63 6c 65 22 20 64 nc-duty-cycle" d
4c80: 65 66 61 75 6c 74 3a 20 64 65 66 61 75 6c 74 2d efault: default-
4c90: 64 75 74 79 2d 63 79 63 6c 65 29 29 0a 20 20 20 duty-cycle)).
4ca0: 20 20 20 20 20 20 28 6c 61 73 74 2d 73 79 6e 63 (last-sync
4cb0: 2d 73 65 63 6f 6e 64 73 20 31 30 29 20 3b 3b 20 -seconds 10) ;;
4cc0: 77 65 20 77 69 6c 6c 20 61 64 6a 75 73 74 20 74 we will adjust t
4cd0: 68 69 73 20 74 6f 20 61 20 6d 65 61 73 75 72 65 his to a measure
4ce0: 6d 65 6e 74 20 61 6e 64 20 64 65 6c 61 79 20 6c ment and delay l
4cf0: 61 73 74 2d 73 79 6e 63 2d 73 65 63 6f 6e 64 73 ast-sync-seconds
4d00: 20 2a 20 28 31 20 2d 20 64 75 74 79 2d 63 79 63 * (1 - duty-cyc
4d10: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 28 63 61 le). (ca
4d20: 6c 63 75 6c 61 74 65 2d 6f 66 66 2d 74 69 6d 65 lculate-off-time
4d30: 20 28 6c 61 6d 62 64 61 20 28 77 6f 72 6b 2d 64 (lambda (work-d
4d40: 75 72 61 74 69 6f 6e 20 64 75 74 79 2d 63 79 63 uration duty-cyc
4d50: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 le).
4d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d70: 20 20 20 20 20 20 28 2a 20 28 2f 20 28 2d 20 31 (* (/ (- 1
4d80: 20 64 75 74 79 2d 63 79 63 6c 65 29 20 64 75 74 duty-cycle) dut
4d90: 79 2d 63 79 63 6c 65 29 20 6c 61 73 74 2d 73 79 y-cycle) last-sy
4da0: 6e 63 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 nc-seconds))).
4db0: 20 20 20 20 20 20 20 28 6f 66 66 2d 74 69 6d 65 (off-time
4dc0: 20 6d 69 6e 2d 69 6e 74 65 72 73 79 6e 63 2d 64 min-intersync-d
4dd0: 65 6c 61 79 29 20 3b 3b 20 61 64 6a 75 73 74 65 elay) ;; adjuste
4de0: 64 20 69 6e 20 63 6c 6f 73 75 72 65 20 62 65 6c d in closure bel
4df0: 6f 77 2e 0a 20 20 20 20 20 20 20 20 20 28 64 6f ow.. (do
4e00: 2d 61 2d 73 79 6e 63 0a 20 20 20 20 20 20 20 20 -a-sync.
4e10: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
4e20: 20 20 20 20 20 20 20 20 20 28 42 42 3e 20 22 53 (BB> "S
4e30: 74 61 72 74 20 64 6f 2d 61 2d 73 79 6e 63 20 77 tart do-a-sync w
4e40: 69 74 68 20 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b ith fork-to-back
4e50: 67 72 6f 75 6e 64 3d 22 66 6f 72 6b 2d 74 6f 2d ground="fork-to-
4e60: 62 61 63 6b 67 72 6f 75 6e 64 22 20 70 65 72 73 background" pers
4e70: 69 73 74 2d 75 6e 74 69 6c 2d 73 79 6e 63 3d 22 ist-until-sync="
4e80: 70 65 72 73 69 73 74 2d 75 6e 74 69 6c 2d 73 79 persist-until-sy
4e90: 6e 63 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 nc).
4ea0: 28 6c 65 74 2a 20 28 28 66 69 6e 61 6c 72 65 73 (let* ((finalres
4eb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4ec0: 20 20 20 20 20 28 6c 65 74 20 72 65 74 72 79 2d (let retry-
4ed0: 6c 6f 6f 70 20 28 28 6e 75 6d 2d 74 72 69 65 73 loop ((num-tries
4ee0: 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0)).
4ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
4f00: 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 f (common:simple
4f10: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 -file-lock lockf
4f20: 69 6c 65 29 0a 09 20 20 20 20 20 20 20 20 20 20 ile)..
4f30: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
4f40: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
4f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f60: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
4f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f80: 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 6f 72 ((not (or
4f90: 20 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 6f fork-to-backgro
4fa0: 75 6e 64 20 70 65 72 73 69 73 74 2d 75 6e 74 69 und persist-unti
4fb0: 6c 2d 73 79 6e 63 29 29 0a 20 20 20 20 20 20 20 l-sync)).
4fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4fd0: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
4fe0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
4ff0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
5000: 4f 3a 20 73 79 6e 63 65 72 20 74 68 72 65 61 64 O: syncer thread
5010: 20 73 6c 65 65 70 69 6e 67 20 66 6f 72 20 6d 61 sleeping for ma
5020: 78 20 6f 66 20 28 73 65 72 76 65 72 2e 6d 69 6e x of (server.min
5030: 69 6d 75 6d 2d 69 6e 74 65 72 73 79 6e 63 2d 64 imum-intersync-d
5040: 65 6c 61 79 3d 22 6d 69 6e 2d 69 6e 74 65 72 73 elay="min-inters
5050: 79 6e 63 2d 64 65 6c 61 79 0a 20 20 20 20 20 20 ync-delay.
5060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5080: 20 20 20 20 20 20 20 20 22 20 2c 20 6f 66 66 2d " , off-
5090: 74 69 6d 65 3d 22 6f 66 66 2d 74 69 6d 65 22 20 time="off-time"
50a0: 73 65 63 6f 6e 64 73 20 5d 22 29 0a 20 20 20 20 seconds ]").
50b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
50c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 68 (th
50d0: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 6d 61 78 read-sleep! (max
50e0: 20 6f 66 66 2d 74 69 6d 65 20 6d 69 6e 2d 69 6e off-time min-in
50f0: 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 29 29 29 tersync-delay)))
5100: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5120: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 (else.
5130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5140: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
5150: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
5160: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
5170: 20 73 79 6e 63 65 72 20 74 68 72 65 61 64 20 4e syncer thread N
5180: 4f 54 20 73 6c 65 65 70 69 6e 67 20 3b 20 6d 61 OT sleeping ; ma
5190: 79 62 65 20 74 69 6d 65 2d 74 6f 2d 65 78 69 74 ybe time-to-exit
51a0: 2e 2e 2e 22 29 29 29 0a 0a 20 20 20 20 20 20 20 ...")))..
51b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
51c0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
51d0: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
51e0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
51f0: 72 76 65 72 22 20 22 64 69 73 61 62 6c 65 2d 64 rver" "disable-d
5200: 62 2d 73 6e 61 70 73 68 6f 74 22 29 29 0a 20 20 b-snapshot")).
5210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5230: 20 28 63 6f 6d 6d 6f 6e 3a 73 6e 61 70 73 68 6f (common:snapsho
5240: 74 2d 66 69 6c 65 20 6d 74 64 62 66 69 6c 65 20 t-file mtdbfile
5250: 73 75 62 64 69 72 3a 20 22 2e 64 62 2d 73 6e 61 subdir: ".db-sna
5260: 70 73 68 6f 74 22 29 29 0a 09 09 20 20 20 20 20 pshot"))...
5270: 20 20 20 20 20 20 20 20 20 20 28 64 65 6c 65 74 (delet
5280: 65 2d 66 69 6c 65 2a 20 73 74 61 67 69 6e 67 2d e-file* staging-
5290: 66 69 6c 65 29 0a 09 09 20 20 20 20 20 20 20 20 file)...
52a0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 (let* ((s
52b0: 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 tart-time (curre
52c0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
52d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
52e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52f0: 20 20 20 20 20 20 20 20 28 72 65 73 20 28 73 79 (res (sy
5300: 73 74 65 6d 20 73 79 6e 63 2d 63 6d 64 29 29 0a stem sync-cmd)).
5310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5330: 20 20 20 20 20 20 28 72 65 73 32 20 0a 20 20 20 (res2 .
5340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5360: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond.
5370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5390: 20 20 28 28 65 71 3f 20 30 20 72 65 73 29 0a 09 ((eq? 0 res)..
53a0: 09 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
53b0: 20 20 20 20 20 20 20 20 20 20 28 64 65 6c 65 74 (delet
53c0: 65 2d 66 69 6c 65 2a 20 28 63 6f 6e 63 20 6d 74 e-file* (conc mt
53d0: 64 62 66 69 6c 65 20 22 2e 62 61 63 6b 75 70 22 dbfile ".backup"
53e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
53f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5400: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
5410: 28 65 71 3f 20 30 20 28 66 69 6c 65 2d 73 69 7a (eq? 0 (file-siz
5420: 65 20 73 79 6e 63 2d 6c 6f 67 29 29 0a 20 20 20 e sync-log)).
5430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5450: 20 20 20 20 20 20 20 20 20 20 28 64 65 6c 65 74 (delet
5460: 65 2d 66 69 6c 65 20 73 79 6e 63 2d 6c 6f 67 29 e-file sync-log)
5470: 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 20 20 )...
5480: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 79 (sy
5490: 73 74 65 6d 20 28 63 6f 6e 63 20 22 2f 62 69 6e stem (conc "/bin
54a0: 2f 6d 76 20 22 20 73 74 61 67 69 6e 67 2d 66 69 /mv " staging-fi
54b0: 6c 65 20 22 20 22 20 6d 74 64 62 66 69 6c 65 29 le " " mtdbfile)
54c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
54d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
54e0: 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 .
54f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5510: 20 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 2d (set! last-
5520: 73 79 6e 63 2d 73 65 63 6f 6e 64 73 20 28 2f 20 sync-seconds (/
5530: 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (- (current-mill
5540: 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d iseconds) start-
5550: 74 69 6d 65 29 20 31 30 30 30 29 29 0a 20 20 20 time) 1000)).
5560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5580: 20 20 20 20 20 20 28 73 65 74 21 20 6f 66 66 2d (set! off-
5590: 74 69 6d 65 20 28 63 61 6c 63 75 6c 61 74 65 2d time (calculate-
55a0: 6f 66 66 2d 74 69 6d 65 0a 20 20 20 20 20 20 20 off-time.
55b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55e0: 20 20 6c 61 73 74 2d 73 79 6e 63 2d 73 65 63 6f last-sync-seco
55f0: 6e 64 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 nds.
5600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5620: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
5630: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
5640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5660: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 ((a
5670: 6e 64 20 28 6e 75 6d 62 65 72 3f 20 64 75 74 79 nd (number? duty
5680: 2d 63 79 63 6c 65 29 20 28 3e 20 64 75 74 79 2d -cycle) (> duty-
5690: 63 79 63 6c 65 20 30 29 20 28 3c 20 64 75 74 79 cycle 0) (< duty
56a0: 2d 63 79 63 6c 65 20 31 29 29 0a 20 20 20 20 20 -cycle 1)).
56b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56e0: 20 20 20 20 20 20 64 75 74 79 2d 63 79 63 6c 65 duty-cycle
56f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5720: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
5730: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
5740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5760: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
5770: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
5780: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5790: 57 41 52 4e 49 4e 47 3a 20 5b 22 28 63 6f 6d 6d WARNING: ["(comm
57a0: 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 22 5d on:human-time)"]
57b0: 20 73 65 72 76 65 72 2e 73 79 6e 63 2d 64 75 74 server.sync-dut
57c0: 79 2d 63 79 63 6c 65 20 69 73 20 69 6e 76 61 6c y-cycle is inval
57d0: 69 64 2e 20 20 53 68 6f 75 6c 64 20 62 65 20 61 id. Should be a
57e0: 20 6e 75 6d 62 65 72 20 62 65 74 77 65 65 6e 20 number between
57f0: 30 20 61 6e 64 20 31 2c 20 62 75 74 20 22 64 75 0 and 1, but "du
5800: 74 79 2d 63 79 63 6c 65 22 20 77 61 73 20 73 70 ty-cycle" was sp
5810: 65 63 69 66 69 65 64 2e 20 20 55 73 69 6e 67 20 ecified. Using
5820: 64 65 66 61 75 6c 74 20 76 61 6c 75 65 3a 20 22 default value: "
5830: 64 65 66 61 75 6c 74 2d 64 75 74 79 2d 63 79 63 default-duty-cyc
5840: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 le).
5850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 20 20 20 20 20 20 64 d
5880: 65 66 61 75 6c 74 2d 64 75 74 79 2d 63 79 63 6c efault-duty-cycl
5890: 65 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 e)))).
58a0: 20 20 20 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 0a .
58c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58e0: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
58f0: 70 72 69 6e 74 20 31 20 2a 64 65 66 61 75 6c 74 print 1 *default
5900: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
5910: 3a 20 5b 22 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 : ["(common:huma
5920: 6e 2d 74 69 6d 65 29 22 5d 20 70 69 64 3d 22 28 n-time)"] pid="(
5930: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
5940: 69 64 29 22 20 53 59 4e 43 20 74 6f 6f 6b 20 22 id)" SYNC took "
5950: 6c 61 73 74 2d 73 79 6e 63 2d 73 65 63 6f 6e 64 last-sync-second
5960: 73 22 20 73 65 63 22 29 0a 20 20 20 20 20 20 20 s" sec").
5970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5990: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
59a0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
59b0: 72 74 2a 20 22 49 4e 46 4f 3a 20 5b 22 28 63 6f rt* "INFO: ["(co
59c0: 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 mmon:human-time)
59d0: 22 5d 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 "] pid="(current
59e0: 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 53 59 -process-id)" SY
59f0: 4e 43 20 74 6f 6f 6b 20 22 6c 61 73 74 2d 73 79 NC took "last-sy
5a00: 6e 63 2d 73 65 63 6f 6e 64 73 22 20 73 65 63 20 nc-seconds" sec
5a10: 3b 20 77 69 74 68 20 64 75 74 79 2d 63 79 63 6c ; with duty-cycl
5a20: 65 20 6f 66 20 22 64 75 74 79 2d 63 79 63 6c 65 e of "duty-cycle
5a30: 22 20 6f 66 66 20 74 69 6d 65 20 69 73 20 6e 6f " off time is no
5a40: 77 20 22 6f 66 66 2d 74 69 6d 65 29 0a 20 20 20 w "off-time).
5a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a70: 20 20 20 20 20 20 27 73 79 6e 63 2d 63 6f 6d 70 'sync-comp
5a80: 6c 65 74 65 64 29 0a 20 20 20 20 20 20 20 20 20 leted).
5a90: 20 20 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 20 20 20 28 (
5ab0: 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 else.
5ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
5ae0: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 2f 62 69 ystem (conc "/bi
5af0: 6e 2f 63 70 20 22 73 79 6e 63 2d 6c 6f 67 22 20 n/cp "sync-log"
5b00: 22 73 79 6e 63 2d 6c 6f 67 22 2e 66 61 69 6c 22 "sync-log".fail"
5b10: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b30: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
5b40: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
5b50: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
5b60: 52 52 4f 52 3a 20 5b 22 28 63 6f 6d 6d 6f 6e 3a RROR: ["(common:
5b70: 68 75 6d 61 6e 2d 74 69 6d 65 29 22 5d 20 53 79 human-time)"] Sy
5b80: 6e 63 20 66 61 69 6c 65 64 2e 20 53 65 65 20 6c nc failed. See l
5b90: 6f 67 20 61 74 20 22 73 79 6e 63 2d 6c 6f 67 22 og at "sync-log"
5ba0: 2e 66 61 69 6c 22 29 0a 20 20 20 20 20 20 20 20 .fail").
5bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bd0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
5be0: 73 3f 20 28 63 6f 6e 63 20 6d 74 64 62 66 69 6c s? (conc mtdbfil
5bf0: 65 20 22 2e 62 61 63 6b 75 70 22 29 29 0a 20 20 e ".backup")).
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 20 20 20 20 20 20 20 20 20 28 73 79 73 74 (syst
5c30: 65 6d 20 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 63 em (conc "/bin/c
5c40: 70 20 22 6d 74 64 62 66 69 6c 65 20 22 2e 62 61 p "mtdbfile ".ba
5c50: 63 6b 75 70 20 22 20 6d 74 64 62 66 69 6c 65 29 ckup " mtdbfile)
5c60: 29 29 0a 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 20 20 20 20 20 20 20 20 20 23 66 29 29 #f))
5c90: 29 29 0a 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: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 (common:simp
5cc0: 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d le-file-release-
5cd0: 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 20 lock lockfile).
5ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d00: 28 42 42 3e 20 22 72 65 6c 65 61 73 65 64 20 6c (BB> "released l
5d10: 6f 63 6b 66 69 6c 65 3a 20 22 20 6c 6f 63 6b 66 ockfile: " lockf
5d20: 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ile).
5d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d40: 20 20 20 20 20 20 28 77 68 65 6e 20 28 63 6f 6d (when (com
5d50: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
5d60: 20 6c 6f 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 lockfile).
5d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 42 (B
5d90: 42 3e 20 22 44 49 44 20 4e 4f 54 20 41 43 54 55 B> "DID NOT ACTU
5da0: 41 4c 4c 59 20 52 45 4c 45 41 53 45 20 4c 4f 43 ALLY RELEASE LOC
5db0: 4b 46 49 4c 45 22 29 29 0a 20 20 20 20 20 20 20 KFILE")).
5dc0: 20 20 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 72 65 73 32 29 20 res2)
5de0: 3b 3b 20 65 6e 64 20 6c 65 74 0a 20 20 20 20 20 ;; end let.
5df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e00: 20 20 20 20 20 20 20 20 20 20 29 3b 3b 20 65 6e );; en
5e10: 64 20 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 d begin.
5e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e30: 20 20 20 20 20 3b 3b 20 65 6c 73 65 0a 20 20 20 ;; else.
5e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e50: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
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 28 70 (p
5e80: 65 72 73 69 73 74 2d 75 6e 74 69 6c 2d 73 79 6e ersist-until-syn
5e90: 63 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 c.
5ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5eb0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
5ec0: 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1).
5ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ee0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
5ef0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5f00: 72 74 2a 20 22 49 4e 46 4f 3a 20 5b 22 28 63 6f rt* "INFO: ["(co
5f10: 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 mmon:human-time)
5f20: 22 5d 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 "] pid="(current
5f30: 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 6f 74 -process-id)" ot
5f40: 68 65 72 20 53 59 4e 43 20 69 6e 20 70 72 6f 67 her SYNC in prog
5f50: 72 65 73 73 3b 20 77 65 27 72 65 20 69 6e 20 61 ress; we're in a
5f60: 20 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 6f fork-to-backgro
5f70: 75 6e 64 20 73 6f 20 77 65 20 6e 65 65 64 20 74 und so we need t
5f80: 6f 20 73 75 63 63 65 65 64 2e 20 20 4c 65 74 27 o succeed. Let'
5f90: 73 20 77 61 69 74 20 61 20 6a 69 66 66 79 20 61 s wait a jiffy a
5fa0: 6e 64 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e nd and try again
5fb0: 2e 20 6e 75 6d 2d 74 72 69 65 73 3d 22 6e 75 6d . num-tries="num
5fc0: 2d 74 72 69 65 73 22 20 28 77 61 69 74 69 6e 67 -tries" (waiting
5fd0: 20 66 6f 72 20 6c 6f 63 6b 66 69 6c 65 3d 22 6c for lockfile="l
5fe0: 6f 63 6b 66 69 6c 65 22 20 74 6f 20 64 69 73 61 ockfile" to disa
5ff0: 70 70 65 61 72 29 22 29 0a 20 20 20 20 20 20 20 ppear)").
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 28 72 65 74 72 79 2d 6c (retry-l
6020: 6f 6f 70 20 28 61 64 64 31 20 6e 75 6d 2d 74 72 oop (add1 num-tr
6030: 69 65 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 ies))).
6040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6050: 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
6060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6070: 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 61 (threa
6080: 64 2d 73 6c 65 65 70 21 20 28 6d 61 78 20 6f 66 d-sleep! (max of
6090: 66 2d 74 69 6d 65 20 28 2b 20 6c 61 73 74 2d 73 f-time (+ last-s
60a0: 79 6e 63 2d 73 65 63 6f 6e 64 73 20 6d 69 6e 2d ync-seconds min-
60b0: 69 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 29 intersync-delay)
60c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
60d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
60f0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6100: 72 74 2a 20 22 49 4e 46 4f 3a 20 5b 22 28 63 6f rt* "INFO: ["(co
6110: 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 mmon:human-time)
6120: 22 5d 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 "] pid="(current
6130: 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 6f 74 -process-id)" ot
6140: 68 65 72 20 53 59 4e 43 20 69 6e 20 70 72 6f 67 her SYNC in prog
6150: 72 65 73 73 3b 20 6e 6f 74 20 73 79 6e 63 69 6e ress; not syncin
6160: 67 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 g.").
6170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6180: 20 20 20 20 27 70 61 72 61 6c 6c 65 6c 2d 73 79 'parallel-sy
6190: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 29 29 nc-in-progress))
61a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
61b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 20 )
61c0: 3b 3b 20 65 6e 64 20 69 66 20 67 6f 74 20 6c 6f ;; end if got lo
61d0: 63 6b 66 69 6c 65 0a 20 20 20 20 20 20 20 20 20 ckfile.
61e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
61f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6200: 20 20 20 20 20 20 29 29 0a 20 20 20 20 20 20 20 )).
6210: 20 20 20 20 20 20 20 28 42 42 3e 20 22 45 6e 64 (BB> "End
6220: 20 64 6f 2d 61 2d 73 79 6e 63 20 77 69 74 68 20 do-a-sync with
6230: 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 6f 75 fork-to-backgrou
6240: 6e 64 3d 22 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b nd="fork-to-back
6250: 67 72 6f 75 6e 64 22 20 70 65 72 73 69 73 74 2d ground" persist-
6260: 75 6e 74 69 6c 2d 73 79 6e 63 3d 22 70 65 72 73 until-sync="pers
6270: 69 73 74 2d 75 6e 74 69 6c 2d 73 79 6e 63 22 20 ist-until-sync"
6280: 61 6e 64 20 72 65 73 75 6c 74 3d 22 66 69 6e 61 and result="fina
6290: 6c 72 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 lres).
62a0: 20 20 20 20 66 69 6e 61 6c 72 65 73 29 0a 20 20 finalres).
62b0: 20 20 20 20 20 20 20 20 20 20 29 20 3b 3b 20 65 ) ;; e
62c0: 6e 64 20 6c 61 6d 62 64 61 0a 20 20 20 20 20 20 nd lambda.
62d0: 20 20 20 20 29 29 0a 20 20 20 20 64 6f 2d 61 2d )). do-a-
62e0: 73 79 6e 63 29 29 0a 0a 28 64 65 66 69 6e 65 20 sync))..(define
62f0: 28 73 65 72 76 65 72 3a 77 72 69 74 61 62 6c 65 (server:writable
6300: 2d 77 61 74 63 68 64 6f 67 2d 62 72 75 74 65 66 -watchdog-brutef
6310: 6f 72 63 65 20 64 62 73 74 72 75 63 74 29 0a 20 orce dbstruct).
6320: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
6330: 31 29 20 3b 3b 20 64 65 6c 61 79 20 66 6f 72 20 1) ;; delay for
6340: 73 74 61 72 74 75 70 0a 20 20 28 6c 65 74 2a 20 startup. (let*
6350: 28 28 64 6f 2d 61 2d 73 79 6e 63 20 20 28 73 65 ((do-a-sync (se
6360: 72 76 65 72 3a 67 65 74 2d 62 72 75 74 65 66 6f rver:get-brutefo
6370: 72 63 65 2d 73 79 6e 63 65 72 20 64 62 73 74 72 rce-syncer dbstr
6380: 75 63 74 29 29 0a 20 20 20 20 20 20 20 20 20 28 uct)). (
6390: 66 69 6e 61 6c 2d 73 79 6e 63 20 28 73 65 72 76 final-sync (serv
63a0: 65 72 3a 67 65 74 2d 62 72 75 74 65 66 6f 72 63 er:get-bruteforc
63b0: 65 2d 73 79 6e 63 65 72 20 64 62 73 74 72 75 63 e-syncer dbstruc
63c0: 74 20 66 6f 72 6b 2d 74 6f 2d 62 61 63 6b 67 72 t fork-to-backgr
63d0: 6f 75 6e 64 3a 20 23 74 20 70 65 72 73 69 73 74 ound: #t persist
63e0: 2d 75 6e 74 69 6c 2d 73 79 6e 63 3a 20 23 74 29 -until-sync: #t)
63f0: 29 29 0a 20 20 20 20 28 77 68 65 6e 20 28 61 6e )). (when (an
6400: 64 20 28 6e 6f 74 20 28 61 72 67 73 3a 67 65 74 d (not (args:get
6410: 2d 61 72 67 20 22 2d 73 79 6e 63 2d 74 6f 2d 6d -arg "-sync-to-m
6420: 65 67 61 74 65 73 74 2e 64 62 22 29 29 20 3b 3b egatest.db")) ;;
6430: 20 63 6f 6e 64 69 74 69 6f 6e 73 20 75 6e 64 65 conditions unde
6440: 72 20 77 68 69 63 68 20 77 65 20 64 6f 20 6e 6f r which we do no
6450: 74 20 72 75 6e 20 74 68 65 20 73 79 6e 63 0a 09 t run the sync..
6460: 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 (args:get
6470: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 -arg "-server"))
6480: 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 28 6c . . (l
6490: 65 74 20 6c 6f 6f 70 20 28 29 0a 09 28 64 6f 2d et loop ()..(do-
64a0: 61 2d 73 79 6e 63 29 0a 20 20 20 20 20 20 20 20 a-sync).
64b0: 28 69 66 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 (if (not *time-t
64c0: 6f 2d 65 78 69 74 2a 29 20 28 6c 6f 6f 70 29 29 o-exit*) (loop))
64d0: 29 20 3b 3b 20 6b 65 65 70 20 67 6f 69 6e 67 20 ) ;; keep going
64e0: 75 6e 6c 65 73 73 20 74 69 6d 65 20 74 6f 20 65 unless time to e
64f0: 78 69 74 0a 0a 20 20 20 20 20 20 3b 3b 20 74 69 xit.. ;; ti
6500: 6d 65 20 74 6f 20 65 78 69 74 2c 20 63 6c 6f 73 me to exit, clos
6510: 65 20 74 68 65 20 6e 6f 2d 73 79 6e 63 20 64 62 e the no-sync db
6520: 20 68 65 72 65 0a 20 20 20 20 20 20 28 66 69 6e here. (fin
6530: 61 6c 2d 73 79 6e 63 29 0a 0a 20 20 20 20 20 20 al-sync)..
6540: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (if (common:low-
6550: 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 29 0a noise-print 30).
6560: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
6570: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
6580: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 log-port* "Exiti
6590: 6e 67 20 77 61 74 63 68 64 6f 67 20 74 69 6d 65 ng watchdog time
65a0: 72 2c 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 r, *time-to-exit
65b0: 2a 20 3d 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 * = " *time-to-e
65c0: 78 69 74 2a 22 20 70 69 64 3d 22 28 63 75 72 72 xit*" pid="(curr
65d0: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 0a ent-process-id).
65e0: 09 09 09 20 20 20 20 29 29 29 29 29 0a 0a 28 64 ... )))))..(d
65f0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 77 72 efine (server:wr
6600: 69 74 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 2d itable-watchdog-
6610: 64 65 6c 74 61 73 79 6e 63 20 64 62 73 74 72 75 deltasync dbstru
6620: 63 74 29 0a 20 20 28 74 68 72 65 61 64 2d 73 6c ct). (thread-sl
6630: 65 65 70 21 20 30 2e 30 35 29 20 3b 3b 20 64 65 eep! 0.05) ;; de
6640: 6c 61 79 20 66 6f 72 20 73 74 61 72 74 75 70 0a lay for startup.
6650: 20 20 28 6c 65 74 20 28 28 6c 65 67 61 63 79 2d (let ((legacy-
6660: 73 79 6e 63 20 20 28 63 6f 6d 6d 6f 6e 3a 72 75 sync (common:ru
6670: 6e 2d 73 79 6e 63 3f 29 29 0a 20 20 20 20 20 20 n-sync?)).
6680: 20 20 28 73 79 6e 63 2d 73 74 61 6c 65 2d 73 65 (sync-stale-se
6690: 63 6f 6e 64 73 20 28 63 6f 6e 66 69 67 66 3a 6c conds (configf:l
66a0: 6f 6f 6b 75 70 2d 6e 75 6d 62 65 72 20 2a 63 6f ookup-number *co
66b0: 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 nfigdat* "server
66c0: 22 20 22 73 79 6e 63 2d 73 74 61 6c 65 2d 73 65 " "sync-stale-se
66d0: 63 6f 6e 64 73 22 20 64 65 66 61 75 6c 74 3a 20 conds" default:
66e0: 33 30 30 29 29 0a 09 28 64 65 62 75 67 2d 6d 6f 300))..(debug-mo
66f0: 64 65 20 20 20 28 64 65 62 75 67 3a 64 65 62 75 de (debug:debu
6700: 67 2d 6d 6f 64 65 20 31 29 29 0a 09 28 6c 61 73 g-mode 1))..(las
6710: 74 2d 74 69 6d 65 20 20 20 20 28 63 75 72 72 65 t-time (curre
6720: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 28 6e nt-seconds))..(n
6730: 6f 2d 73 79 6e 63 2d 64 62 20 20 20 28 64 62 3a o-sync-db (db:
6740: 6f 70 65 6e 2d 6e 6f 2d 73 79 6e 63 2d 64 62 29 open-no-sync-db)
6750: 29 0a 20 20 20 20 20 20 20 20 28 73 79 6e 63 2d ). (sync-
6760: 64 75 72 61 74 69 6f 6e 20 30 29 20 3b 3b 20 72 duration 0) ;; r
6770: 75 6e 20 74 69 6d 65 20 6f 66 20 74 68 65 20 73 un time of the s
6780: 79 6e 63 20 69 6e 20 6d 69 6c 6c 69 73 65 63 6f ync in milliseco
6790: 6e 64 73 0a 20 20 20 20 20 20 20 20 3b 3b 28 74 nds. ;;(t
67a0: 68 69 73 2d 77 64 2d 6e 75 6d 20 20 28 62 65 67 his-wd-num (beg
67b0: 69 6e 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 in (mutex-lock!
67c0: 2a 77 64 6e 75 6d 2a 6d 75 74 65 78 29 20 28 6c *wdnum*mutex) (l
67d0: 65 74 20 28 28 78 20 2a 77 64 6e 75 6d 2a 29 29 et ((x *wdnum*))
67e0: 20 28 73 65 74 21 20 2a 77 64 6e 75 6d 2a 20 28 (set! *wdnum* (
67f0: 61 64 64 31 20 2a 77 64 6e 75 6d 2a 29 29 20 28 add1 *wdnum*)) (
6800: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 77 mutex-unlock! *w
6810: 64 6e 75 6d 2a 6d 75 74 65 78 29 20 78 29 29 29 dnum*mutex) x)))
6820: 0a 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 28 . ). (
6830: 73 65 74 21 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 set! *no-sync-db
6840: 2a 20 6e 6f 2d 73 79 6e 63 2d 64 62 29 20 3b 3b * no-sync-db) ;;
6850: 20 6d 61 6b 65 20 74 68 65 20 6e 6f 20 73 79 6e make the no syn
6860: 63 20 64 62 20 61 76 61 69 6c 61 62 6c 65 20 74 c db available t
6870: 6f 20 61 70 69 20 63 61 6c 6c 73 0a 20 20 20 20 o api calls.
6880: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6890: 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 2 *default-log
68a0: 2d 70 6f 72 74 2a 20 22 50 65 72 69 6f 64 69 63 -port* "Periodic
68b0: 20 73 79 6e 63 20 74 68 72 65 61 64 20 73 74 61 sync thread sta
68c0: 72 74 65 64 2e 22 29 0a 20 20 20 20 28 64 65 62 rted."). (deb
68d0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 ug:print-info 3
68e0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
68f0: 74 2a 20 22 77 61 74 63 68 64 6f 67 20 73 74 61 t* "watchdog sta
6900: 72 74 69 6e 67 2e 20 6c 65 67 61 63 79 2d 73 79 rting. legacy-sy
6910: 6e 63 20 69 73 20 22 20 6c 65 67 61 63 79 2d 73 nc is " legacy-s
6920: 79 6e 63 22 20 70 69 64 3d 22 28 63 75 72 72 65 ync" pid="(curre
6930: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 20 nt-process-id)
6940: 29 3b 3b 20 20 22 20 74 68 69 73 2d 77 64 2d 6e );; " this-wd-n
6950: 75 6d 3d 22 74 68 69 73 2d 77 64 2d 6e 75 6d 29 um="this-wd-num)
6960: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 6c 65 . (if (and le
6970: 67 61 63 79 2d 73 79 6e 63 20 28 6e 6f 74 20 2a gacy-sync (not *
6980: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 29 0a time-to-exit*)).
6990: 09 28 6c 65 74 2a 20 28 3b 3b 28 64 62 73 74 72 .(let* (;;(dbstr
69a0: 75 63 74 20 28 64 62 3a 73 65 74 75 70 29 29 0a uct (db:setup)).
69b0: 09 20 20 20 20 20 20 20 28 6d 74 64 62 20 20 20 . (mtdb
69c0: 20 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 (dbr:dbstruc
69d0: 74 2d 6d 74 64 62 20 64 62 73 74 72 75 63 74 29 t-mtdb dbstruct)
69e0: 29 0a 09 20 20 20 20 20 20 20 28 6d 74 70 61 74 ).. (mtpat
69f0: 68 20 20 20 20 20 28 64 62 3a 64 62 64 61 74 2d h (db:dbdat-
6a00: 67 65 74 2d 70 61 74 68 20 6d 74 64 62 29 29 0a get-path mtdb)).
6a10: 09 20 20 20 20 20 20 20 28 74 6d 70 2d 61 72 65 . (tmp-are
6a20: 61 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d a (common:get-
6a30: 64 62 2d 74 6d 70 2d 61 72 65 61 20 2a 61 6c 6c db-tmp-area *all
6a40: 64 61 74 2a 29 29 0a 09 20 20 20 20 20 20 20 28 dat*)).. (
6a50: 73 74 61 72 74 2d 66 69 6c 65 20 28 63 6f 6e 63 start-file (conc
6a60: 20 74 6d 70 2d 61 72 65 61 20 22 2f 2e 73 74 61 tmp-area "/.sta
6a70: 72 74 2d 73 79 6e 63 22 29 29 0a 09 20 20 20 20 rt-sync"))..
6a80: 20 20 20 28 65 6e 64 2d 66 69 6c 65 20 20 20 28 (end-file (
6a90: 63 6f 6e 63 20 74 6d 70 2d 61 72 65 61 20 22 2f conc tmp-area "/
6aa0: 2e 65 6e 64 2d 73 79 6e 63 22 29 29 29 0a 09 20 .end-sync")))..
6ab0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
6ac0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
6ad0: 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 g-port* "Server
6ae0: 72 75 6e 6e 69 6e 67 2c 20 70 65 72 69 6f 64 69 running, periodi
6af0: 63 20 73 79 6e 63 20 73 74 61 72 74 65 64 2e 22 c sync started."
6b00: 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 ).. (let loop (
6b10: 29 0a 09 20 20 20 20 3b 3b 20 73 79 6e 63 20 66 ).. ;; sync f
6b20: 6f 72 20 66 69 6c 65 73 79 73 74 65 6d 20 6c 6f or filesystem lo
6b30: 63 61 6c 20 64 62 20 77 72 69 74 65 73 0a 09 20 cal db writes..
6b40: 20 20 20 3b 3b 0a 09 20 20 20 20 28 6d 75 74 65 ;;.. (mute
6b50: 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 x-lock! *db-mult
6b60: 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 i-sync-mutex*)..
6b70: 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 65 64 (let* ((need
6b80: 2d 73 79 6e 63 20 20 20 20 20 20 20 20 28 3e 3d -sync (>=
6b90: 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 *db-last-access
6ba0: 2a 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a * *db-last-sync*
6bb0: 29 29 20 3b 3b 20 6e 6f 20 73 79 6e 63 20 73 69 )) ;; no sync si
6bc0: 6e 63 65 20 6c 61 73 74 20 77 72 69 74 65 0a 09 nce last write..
6bd0: 09 20 20 20 28 73 79 6e 63 2d 69 6e 2d 70 72 6f . (sync-in-pro
6be0: 67 72 65 73 73 20 2a 64 62 2d 73 79 6e 63 2d 69 gress *db-sync-i
6bf0: 6e 2d 70 72 6f 67 72 65 73 73 2a 29 0a 20 20 20 n-progress*).
6c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c10: 28 6d 69 6e 2d 69 6e 74 65 72 73 79 6e 63 2d 64 (min-intersync-d
6c20: 65 6c 61 79 20 28 63 6f 6e 66 69 67 66 3a 6c 6f elay (configf:lo
6c30: 6f 6b 75 70 2d 6e 75 6d 62 65 72 20 2a 63 6f 6e okup-number *con
6c40: 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 figdat* "server"
6c50: 20 22 6d 69 6e 69 6d 75 6d 2d 69 6e 74 65 72 73 "minimum-inters
6c60: 79 6e 63 2d 64 65 6c 61 79 22 20 64 65 66 61 75 ync-delay" defau
6c70: 6c 74 3a 20 35 29 29 0a 09 09 20 20 20 28 73 68 lt: 5))... (sh
6c80: 6f 75 6c 64 2d 73 79 6e 63 20 20 20 20 20 20 28 ould-sync (
6c90: 61 6e 64 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 and (not *time-t
6ca0: 6f 2d 65 78 69 74 2a 29 0a 20 20 20 20 20 20 20 o-exit*).
6cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6cd0: 20 20 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e (> (- (curren
6ce0: 74 2d 73 65 63 6f 6e 64 73 29 20 2a 64 62 2d 6c t-seconds) *db-l
6cf0: 61 73 74 2d 73 79 6e 63 2a 29 20 6d 69 6e 2d 69 ast-sync*) min-i
6d00: 6e 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 29 29 ntersync-delay))
6d10: 29 20 3b 3b 20 73 79 6e 63 20 65 76 65 72 79 20 ) ;; sync every
6d20: 66 69 76 65 20 73 65 63 6f 6e 64 73 20 6d 69 6e five seconds min
6d30: 69 6d 75 6d 2c 20 64 65 70 72 65 63 61 74 65 64 imum, deprecated
6d40: 20 6c 6f 67 69 63 2c 20 63 61 6e 20 70 72 6f 62 logic, can prob
6d50: 61 62 6c 79 20 62 65 20 72 65 6d 6f 76 65 64 0a ably be removed.
6d60: 09 09 20 20 20 28 73 74 61 72 74 2d 74 69 6d 65 .. (start-time
6d70: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
6d80: 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 seconds)).
6d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 70 (cp
6da0: 75 2d 6c 6f 61 64 2d 61 64 6a 20 20 20 20 20 28 u-load-adj (
6db0: 61 6c 69 73 74 2d 72 65 66 20 27 61 64 6a 2d 70 alist-ref 'adj-p
6dc0: 72 6f 63 2d 6c 6f 61 64 20 28 63 6f 6d 6d 6f 6e roc-load (common
6dd0: 3a 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d :get-normalized-
6de0: 63 70 75 2d 6c 6f 61 64 20 23 66 29 29 29 0a 09 cpu-load #f)))..
6df0: 09 20 20 20 28 6d 74 2d 6d 6f 64 2d 74 69 6d 65 . (mt-mod-time
6e00: 20 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 (file-modi
6e10: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6d 74 fication-time mt
6e20: 70 61 74 68 29 29 0a 09 09 20 20 20 28 6c 61 73 path))... (las
6e30: 74 2d 73 79 6e 63 2d 73 74 61 72 74 20 20 28 69 t-sync-start (i
6e40: 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 f (common:file-e
6e50: 78 69 73 74 73 3f 20 73 74 61 72 74 2d 66 69 6c xists? start-fil
6e60: 65 29 0a 09 09 09 09 09 20 28 66 69 6c 65 2d 6d e)...... (file-m
6e70: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
6e80: 20 73 74 61 72 74 2d 66 69 6c 65 29 0a 09 09 09 start-file)....
6e90: 09 09 20 30 29 29 0a 09 09 20 20 20 28 6c 61 73 .. 0))... (las
6ea0: 74 2d 73 79 6e 63 2d 65 6e 64 20 20 20 20 28 69 t-sync-end (i
6eb0: 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 f (common:file-e
6ec0: 78 69 73 74 73 3f 20 65 6e 64 2d 66 69 6c 65 29 xists? end-file)
6ed0: 0a 09 09 09 09 09 20 28 66 69 6c 65 2d 6d 6f 64 ...... (file-mod
6ee0: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 65 ification-time e
6ef0: 6e 64 2d 66 69 6c 65 29 0a 09 09 09 09 09 20 31 nd-file)...... 1
6f00: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
6f10: 20 20 20 20 20 20 20 28 73 79 6e 63 2d 70 65 72 (sync-per
6f20: 69 6f 64 20 20 20 20 20 20 28 2b 20 33 20 28 2a iod (+ 3 (*
6f30: 20 63 70 75 2d 6c 6f 61 64 2d 61 64 6a 20 33 30 cpu-load-adj 30
6f40: 29 29 29 20 3b 3b 20 61 73 20 61 64 6a 75 73 74 ))) ;; as adjust
6f50: 65 64 20 6c 6f 61 64 20 69 6e 63 72 65 61 73 65 ed load increase
6f60: 73 20 69 6e 63 72 65 61 73 65 20 74 68 65 20 73 s increase the s
6f70: 79 6e 63 20 70 65 72 69 6f 64 0a 09 09 20 20 20 ync period...
6f80: 28 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 (recently-synced
6f90: 20 20 28 61 6e 64 20 28 3c 20 28 2d 20 73 74 61 (and (< (- sta
6fa0: 72 74 2d 74 69 6d 65 20 6d 74 2d 6d 6f 64 2d 74 rt-time mt-mod-t
6fb0: 69 6d 65 29 20 73 79 6e 63 2d 70 65 72 69 6f 64 ime) sync-period
6fc0: 29 20 3b 3b 20 6e 6f 74 20 75 73 65 66 75 6c 20 ) ;; not useful
6fd0: 69 66 20 73 79 6e 63 20 64 69 64 6e 27 74 20 6d if sync didn't m
6fe0: 6f 64 69 66 79 20 6d 65 67 61 74 65 73 74 2e 64 odify megatest.d
6ff0: 62 21 0a 09 09 09 09 09 20 20 28 3c 20 6d 74 2d b!...... (< mt-
7000: 6d 6f 64 2d 74 69 6d 65 20 6c 61 73 74 2d 73 79 mod-time last-sy
7010: 6e 63 2d 73 74 61 72 74 29 29 29 0a 09 09 20 20 nc-start)))...
7020: 20 28 73 79 6e 63 2d 64 6f 6e 65 20 20 20 20 20 (sync-done
7030: 20 20 20 28 3c 3d 20 6c 61 73 74 2d 73 79 6e 63 (<= last-sync
7040: 2d 73 74 61 72 74 20 6c 61 73 74 2d 73 79 6e 63 -start last-sync
7050: 2d 65 6e 64 29 29 0a 20 20 20 20 20 20 20 20 20 -end)).
7060: 20 20 20 20 20 20 20 20 20 20 28 73 79 6e 63 2d (sync-
7070: 73 74 61 6c 65 20 20 20 20 20 20 20 28 3e 20 73 stale (> s
7080: 74 61 72 74 2d 74 69 6d 65 20 28 2b 20 6c 61 73 tart-time (+ las
7090: 74 2d 73 79 6e 63 2d 73 74 61 72 74 20 73 79 6e t-sync-start syn
70a0: 63 2d 73 74 61 6c 65 2d 73 65 63 6f 6e 64 73 29 c-stale-seconds)
70b0: 29 29 0a 09 09 20 20 20 28 77 69 6c 6c 2d 73 79 ))... (will-sy
70c0: 6e 63 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 nc (and (
70d0: 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 not *time-to-exi
70e0: 74 2a 29 20 20 20 20 20 20 20 3b 3b 20 64 6f 20 t*) ;; do
70f0: 6e 6f 74 20 73 74 61 72 74 20 61 20 73 79 6e 63 not start a sync
7100: 20 69 66 20 77 65 20 61 72 65 20 69 6e 20 74 68 if we are in th
7110: 65 20 70 72 6f 63 65 73 73 20 6f 66 20 65 78 69 e process of exi
7120: 74 69 6e 67 0a 20 20 20 20 20 20 20 20 20 20 20 ting.
7130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7150: 6f 72 20 6e 65 65 64 2d 73 79 6e 63 20 73 68 6f or need-sync sho
7160: 75 6c 64 2d 73 79 6e 63 29 0a 09 09 09 09 09 20 uld-sync)......
7170: 20 28 6f 72 20 73 79 6e 63 2d 64 6f 6e 65 20 73 (or sync-done s
7180: 79 6e 63 2d 73 74 61 6c 65 29 0a 09 09 09 09 09 ync-stale)......
7190: 20 20 28 6e 6f 74 20 73 79 6e 63 2d 69 6e 2d 70 (not sync-in-p
71a0: 72 6f 67 72 65 73 73 29 0a 09 09 09 09 09 20 20 rogress)......
71b0: 28 6e 6f 74 20 72 65 63 65 6e 74 6c 79 2d 73 79 (not recently-sy
71c0: 6e 63 65 64 29 29 29 29 0a 20 20 20 20 20 20 20 nced)))).
71d0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
71e0: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
71f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7200: 57 44 20 77 72 69 74 61 62 6c 65 2d 77 61 74 63 WD writable-watc
7210: 68 64 6f 67 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 hdog top of loop
7220: 2e 20 20 6e 65 65 64 2d 73 79 6e 63 3d 22 6e 65 . need-sync="ne
7230: 65 64 2d 73 79 6e 63 22 20 73 79 6e 63 2d 69 6e ed-sync" sync-in
7240: 2d 70 72 6f 67 72 65 73 73 3d 22 20 73 79 6e 63 -progress=" sync
7250: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 0a 09 09 09 -in-progress....
7260: 09 22 20 73 68 6f 75 6c 64 2d 73 79 6e 63 3d 22 ." should-sync="
7270: 73 68 6f 75 6c 64 2d 73 79 6e 63 22 20 73 74 61 should-sync" sta
7280: 72 74 2d 74 69 6d 65 3d 22 73 74 61 72 74 2d 74 rt-time="start-t
7290: 69 6d 65 22 20 6d 74 2d 6d 6f 64 2d 74 69 6d 65 ime" mt-mod-time
72a0: 3d 22 6d 74 2d 6d 6f 64 2d 74 69 6d 65 22 20 72 ="mt-mod-time" r
72b0: 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 3d 22 ecently-synced="
72c0: 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 22 recently-synced"
72d0: 20 77 69 6c 6c 2d 73 79 6e 63 3d 22 77 69 6c 6c will-sync="will
72e0: 2d 73 79 6e 63 0a 09 09 09 09 22 20 73 79 6e 63 -sync....." sync
72f0: 2d 64 6f 6e 65 3d 22 20 73 79 6e 63 2d 64 6f 6e -done=" sync-don
7300: 65 20 22 20 73 79 6e 63 2d 70 65 72 69 6f 64 3d e " sync-period=
7310: 22 20 73 79 6e 63 2d 70 65 72 69 6f 64 29 0a 20 " sync-period).
7320: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
7330: 20 28 61 6e 64 20 28 3e 20 73 79 6e 63 2d 70 65 (and (> sync-pe
7340: 72 69 6f 64 20 35 29 0a 20 20 20 20 20 20 20 20 riod 5).
7350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7360: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
7370: 2d 70 72 69 6e 74 20 33 30 20 22 73 79 6e 63 2d -print 30 "sync-
7380: 70 65 72 69 6f 64 22 29 29 0a 20 20 20 20 20 20 period")).
7390: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
73a0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
73b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
73c0: 74 2a 20 22 49 6e 63 72 65 61 73 65 64 20 73 79 t* "Increased sy
73d0: 6e 63 20 70 65 72 69 6f 64 20 64 75 65 20 74 6f nc period due to
73e0: 20 6c 6f 6e 67 20 73 79 6e 63 20 74 69 6d 65 73 long sync times
73f0: 2c 20 73 79 6e 63 20 74 6f 6f 6b 3a 20 22 20 73 , sync took: " s
7400: 79 6e 63 2d 70 65 72 69 6f 64 20 22 20 73 65 63 ync-period " sec
7410: 6f 6e 64 73 2e 22 29 29 0a 09 20 20 20 20 20 20 onds."))..
7420: 3b 3b 20 28 69 66 20 72 65 63 65 6e 74 6c 79 2d ;; (if recently-
7430: 73 79 6e 63 65 64 20 28 64 65 62 75 67 3a 70 72 synced (debug:pr
7440: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
7450: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
7460: 6b 69 70 70 69 6e 67 20 73 79 6e 63 20 64 75 65 kipping sync due
7470: 20 74 6f 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e to recently-syn
7480: 63 65 64 20 66 6c 61 67 3d 22 20 72 65 63 65 6e ced flag=" recen
7490: 74 6c 79 2d 73 79 6e 63 65 64 29 29 0a 09 20 20 tly-synced))..
74a0: 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
74b0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
74c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e ult-log-port* "n
74d0: 65 65 64 2d 73 79 6e 63 3a 20 22 20 6e 65 65 64 eed-sync: " need
74e0: 2d 73 79 6e 63 20 22 20 73 79 6e 63 2d 69 6e 2d -sync " sync-in-
74f0: 70 72 6f 67 72 65 73 73 3a 20 22 20 73 79 6e 63 progress: " sync
7500: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 20 22 20 73 -in-progress " s
7510: 68 6f 75 6c 64 2d 73 79 6e 63 3a 20 22 20 73 68 hould-sync: " sh
7520: 6f 75 6c 64 2d 73 79 6e 63 20 22 20 77 69 6c 6c ould-sync " will
7530: 2d 73 79 6e 63 3a 20 22 20 77 69 6c 6c 2d 73 79 -sync: " will-sy
7540: 6e 63 29 0a 09 20 20 20 20 20 20 28 69 66 20 77 nc).. (if w
7550: 69 6c 6c 2d 73 79 6e 63 20 28 73 65 74 21 20 2a ill-sync (set! *
7560: 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 db-sync-in-progr
7570: 65 73 73 2a 20 23 74 29 29 0a 09 20 20 20 20 20 ess* #t))..
7580: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
7590: 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d *db-multi-sync-m
75a0: 75 74 65 78 2a 29 0a 09 20 20 20 20 20 20 28 69 utex*).. (i
75b0: 66 20 77 69 6c 6c 2d 73 79 6e 63 0a 20 20 20 20 f will-sync.
75c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
75d0: 65 74 20 28 3b 3b 20 28 6d 61 78 2d 73 79 6e 63 et (;; (max-sync
75e0: 2d 64 75 72 61 74 69 6f 6e 20 20 28 63 6f 6e 66 -duration (conf
75f0: 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 65 igf:lookup-numbe
7600: 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 r *configdat* "s
7610: 65 72 76 65 72 22 20 22 6d 61 78 2d 73 79 6e 63 erver" "max-sync
7620: 2d 64 75 72 61 74 69 6f 6e 22 29 29 20 3b 3b 20 -duration")) ;;
7630: 4b 45 45 50 49 4e 47 20 54 48 49 53 20 41 56 41 KEEPING THIS AVA
7640: 49 4c 41 42 4c 45 20 42 55 54 20 53 48 4f 55 4c ILABLE BUT SHOUL
7650: 44 20 4e 4f 54 20 55 53 45 2c 20 49 27 4d 20 50 D NOT USE, I'M P
7660: 52 45 54 54 59 20 53 55 52 45 20 49 54 20 44 4f RETTY SURE IT DO
7670: 45 53 20 4e 4f 54 20 57 4f 52 4b 21 0a 20 20 20 ES NOT WORK!.
7680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7690: 20 20 20 20 20 28 73 79 6e 63 2d 73 74 61 72 74 (sync-start
76a0: 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 6e (curren
76b0: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 t-milliseconds))
76c0: 29 0a 09 09 20 20 20 20 28 77 69 74 68 2d 6f 75 )... (with-ou
76d0: 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 73 74 61 tput-to-file sta
76e0: 72 74 2d 66 69 6c 65 20 28 6c 61 6d 62 64 61 20 rt-file (lambda
76f0: 28 29 28 70 72 69 6e 74 20 28 63 75 72 72 65 6e ()(print (curren
7700: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 t-process-id))))
7710: 0a 09 09 20 20 20 20 0a 09 09 20 20 20 20 3b 3b ... ... ;;
7720: 20 70 75 74 20 6c 6f 63 6b 20 68 65 72 65 0a 09 put lock here..
7730: 09 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 . .
7740: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 69 66 ;; (if
7750: 20 28 6f 72 20 28 6e 6f 74 20 6d 61 78 2d 73 79 (or (not max-sy
7760: 6e 63 2d 64 75 72 61 74 69 6f 6e 29 0a 20 20 20 nc-duration).
7770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7780: 20 3b 3b 20 20 20 20 20 20 20 20 28 3c 20 73 79 ;; (< sy
7790: 6e 63 2d 64 75 72 61 74 69 6f 6e 20 6d 61 78 2d nc-duration max-
77a0: 73 79 6e 63 2d 64 75 72 61 74 69 6f 6e 29 29 20 sync-duration))
77b0: 3b 3b 20 4e 4f 54 45 3a 20 64 62 3a 73 79 6e 63 ;; NOTE: db:sync
77c0: 2d 74 6f 2d 6d 65 67 61 74 65 73 74 2e 64 62 20 -to-megatest.db
77d0: 6b 65 65 70 73 20 74 72 61 63 6b 20 6f 66 20 74 keeps track of t
77e0: 69 6d 65 20 6f 66 20 6c 61 73 74 20 73 79 6e 63 ime of last sync
77f0: 20 61 6e 64 20 73 79 6e 63 73 20 69 6e 63 72 65 and syncs incre
7800: 6d 65 6e 74 61 6c 6c 79 0a 20 20 20 20 20 20 20 mentally.
7810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7820: 20 28 6c 65 74 20 28 28 72 65 73 20 20 20 20 20 (let ((res
7830: 20 20 20 28 64 62 3a 73 79 6e 63 2d 74 6f 2d 6d (db:sync-to-m
7840: 65 67 61 74 65 73 74 2e 64 62 20 64 62 73 74 72 egatest.db dbstr
7850: 75 63 74 20 6e 6f 2d 73 79 6e 63 2d 64 62 3a 20 uct no-sync-db:
7860: 6e 6f 2d 73 79 6e 63 2d 64 62 29 29 29 20 3b 3b no-sync-db))) ;;
7870: 20 64 69 64 20 77 65 20 73 79 6e 63 20 61 6e 79 did we sync any
7880: 20 64 61 74 61 3f 20 49 66 20 73 6f 20 6e 65 65 data? If so nee
7890: 64 20 74 6f 20 73 65 74 20 74 68 65 20 64 62 20 d to set the db
78a0: 74 6f 75 63 68 65 64 20 66 6c 61 67 20 74 6f 20 touched flag to
78b0: 6b 65 65 70 20 74 68 65 20 73 65 72 76 65 72 20 keep the server
78c0: 61 6c 69 76 65 0a 20 20 20 20 20 20 20 20 20 20 alive.
78d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
78e0: 28 73 65 74 21 20 73 79 6e 63 2d 64 75 72 61 74 (set! sync-durat
78f0: 69 6f 6e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d ion (- (current-
7900: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 79 milliseconds) sy
7910: 6e 63 2d 73 74 61 72 74 29 29 0a 20 20 20 20 20 nc-start)).
7920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7930: 20 20 20 20 20 28 69 66 20 28 3e 20 72 65 73 20 (if (> res
7940: 30 29 20 3b 3b 20 73 6f 6d 65 20 72 65 63 6f 72 0) ;; some recor
7950: 64 73 20 77 65 72 65 20 74 72 61 6e 73 66 65 72 ds were transfer
7960: 72 65 64 2c 20 6b 65 65 70 20 74 68 65 20 64 62 red, keep the db
7970: 20 61 6c 69 76 65 0a 20 20 20 20 20 20 20 20 20 alive.
7980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7990: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
79a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 (mut
79c0: 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 ex-lock! *heartb
79d0: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 eat-mutex*).
79e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
7a00: 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 ! *db-last-acces
7a10: 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f s* (current-seco
7a20: 6e 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 nds)).
7a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a40: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
7a50: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
7a60: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 mutex*).
7a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a80: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
7a90: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
7aa0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7ab0: 73 79 6e 63 20 63 61 6c 6c 65 64 2c 20 22 20 72 sync called, " r
7ac0: 65 73 20 22 20 72 65 63 6f 72 64 73 20 74 72 61 es " records tra
7ad0: 6e 73 66 65 72 72 65 64 2e 22 29 29 0a 20 20 20 nsferred.")).
7ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7af0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
7b00: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a g:print-info 2 *
7b10: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7b20: 2a 20 22 73 79 6e 63 20 63 61 6c 6c 65 64 20 62 * "sync called b
7b30: 75 74 20 7a 65 72 6f 20 72 65 63 6f 72 64 73 20 ut zero records
7b40: 74 72 61 6e 73 66 65 72 72 65 64 22 29 29 29 29 transferred"))))
7b50: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
7b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
7b70: 54 4f 44 4f 3a 20 66 61 63 74 6f 72 20 74 68 69 TODO: factor thi
7b80: 73 20 6e 65 78 74 20 72 6f 75 74 69 6e 65 20 6f s next routine o
7b90: 75 74 20 69 6e 74 6f 20 61 20 66 75 6e 63 74 69 ut into a functi
7ba0: 6f 6e 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 on.;;
7bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 (w
7bc0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
7bd0: 69 70 65 20 3b 3b 20 74 68 69 73 20 73 68 6f 75 ipe ;; this shou
7be0: 6c 64 20 6e 6f 74 20 62 6c 6f 63 6b 20 6f 74 68 ld not block oth
7bf0: 65 72 20 74 68 72 65 61 64 73 20 62 75 74 20 6e er threads but n
7c00: 65 65 64 20 74 6f 20 76 65 72 69 66 79 20 74 68 eed to verify th
7c10: 69 73 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 is.;;
7c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7c30: 63 6f 6e 63 20 22 6d 65 67 61 74 65 73 74 20 2d conc "megatest -
7c40: 73 79 6e 63 2d 74 6f 2d 6d 65 67 61 74 65 73 74 sync-to-megatest
7c50: 2e 64 62 20 2d 6d 20 74 65 73 74 73 75 69 74 65 .db -m testsuite
7c60: 3a 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 :" (common:get-a
7c70: 72 65 61 2d 6e 61 6d 65 29 20 22 3a 22 20 2a 74 rea-name) ":" *t
7c80: 6f 70 70 61 74 68 2a 29 0a 3b 3b 20 20 20 20 20 oppath*).;;
7c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ca0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
7cb0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
7cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
7cd0: 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 et loop ((inl (r
7ce0: 65 61 64 2d 6c 69 6e 65 29 29 0a 3b 3b 20 20 20 ead-line)).;;
7cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d10: 20 20 20 20 28 72 65 73 20 23 66 29 29 0a 3b 3b (res #f)).;;
7d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
7d40: 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 f (eof-object? i
7d50: 6e 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 nl).;;
7d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d70: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b (begin.;
7d80: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
7d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7da0: 20 20 20 20 20 28 73 65 74 21 20 73 79 6e 63 2d (set! sync-
7db0: 64 75 72 61 74 69 6f 6e 20 28 2d 20 28 63 75 72 duration (- (cur
7dc0: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
7dd0: 73 29 20 73 79 6e 63 2d 73 74 61 72 74 29 29 0a s) sync-start)).
7de0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
7df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e00: 20 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b 20 20 (cond.;;
7e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e30: 20 20 20 28 28 6e 6f 74 20 72 65 73 29 0a 3b 3b ((not res).;;
7e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e60: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7e70: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
7e80: 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 g-port* "ERROR:
7e90: 73 79 6e 63 20 66 72 6f 6d 20 2f 74 6d 70 20 64 sync from /tmp d
7ea0: 62 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 b to megatest.db
7eb0: 20 61 70 70 65 61 72 73 20 74 6f 20 68 61 76 65 appears to have
7ec0: 20 66 61 69 6c 65 64 2e 20 52 65 63 6f 6d 6d 65 failed. Recomme
7ed0: 6e 64 65 64 20 74 68 61 74 20 79 6f 75 20 73 74 nded that you st
7ee0: 6f 70 20 79 6f 75 72 20 72 75 6e 73 20 61 6e 64 op your runs and
7ef0: 20 72 75 6e 20 5c 22 6d 65 67 61 74 65 73 74 20 run \"megatest
7f00: 2d 63 6c 65 61 6e 75 70 2d 64 62 5c 22 22 29 29 -cleanup-db\""))
7f10: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
7f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f30: 20 20 20 20 20 20 20 20 28 28 3e 20 72 65 73 20 ((> res
7f40: 30 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 0).;;
7f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f60: 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 (mute
7f70: 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 x-lock! *heartbe
7f80: 61 74 2d 6d 75 74 65 78 2a 29 0a 3b 3b 20 20 20 at-mutex*).;;
7f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fb0: 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 (set! *db-las
7fc0: 74 2d 61 63 63 65 73 73 2a 20 28 63 75 72 72 65 t-access* (curre
7fd0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 20 nt-seconds)).;;
7fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8000: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
8010: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
8020: 75 74 65 78 2a 29 29 29 29 0a 3b 3b 20 20 20 20 utex*)))).;;
8030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
8050: 65 74 20 28 28 6e 75 6d 2d 73 79 6e 63 65 64 20 et ((num-synced
8060: 28 6c 65 74 20 28 28 6d 61 74 63 68 65 73 20 28 (let ((matches (
8070: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 53 string-match "^S
8080: 79 6e 63 65 64 20 28 5c 5c 64 2b 29 2e 2a 24 22 ynced (\\d+).*$"
8090: 20 69 6e 6c 29 29 29 0a 3b 3b 20 20 20 20 20 20 inl))).;;
80a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80d0: 28 69 66 20 6d 61 74 63 68 65 73 0a 3b 3b 20 20 (if matches.;;
80e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8110: 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d (string-
8120: 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d 61 >number (cadr ma
8130: 74 63 68 65 73 29 29 0a 3b 3b 20 20 20 20 20 20 tches)).;;
8140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8170: 20 20 20 20 23 66 29 29 29 29 0a 3b 3b 20 20 20 #f)))).;;
8180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81a0: 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e (loop (read-lin
81b0: 65 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 e).;;
81c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
81e0: 6f 72 20 6e 75 6d 2d 73 79 6e 63 65 64 20 72 65 or num-synced re
81f0: 73 29 29 29 29 29 29 29 29 29 29 0a 09 20 20 20 s))))))))))..
8200: 20 20 20 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 (if will-sync
8210: 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 ... (begin...
8220: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
8230: 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 db-multi-sync-mu
8240: 74 65 78 2a 29 0a 09 09 20 20 20 20 28 73 65 74 tex*)... (set
8250: 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 ! *db-sync-in-pr
8260: 6f 67 72 65 73 73 2a 20 23 66 29 0a 09 09 20 20 ogress* #f)...
8270: 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 (set! *db-last
8280: 2d 73 79 6e 63 2a 20 73 74 61 72 74 2d 74 69 6d -sync* start-tim
8290: 65 29 0a 09 09 20 20 20 20 28 77 69 74 68 2d 6f e)... (with-o
82a0: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 65 6e utput-to-file en
82b0: 64 2d 66 69 6c 65 20 28 6c 61 6d 62 64 61 20 28 d-file (lambda (
82c0: 29 28 70 72 69 6e 74 20 28 63 75 72 72 65 6e 74 )(print (current
82d0: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 0a -process-id)))).
82e0: 0a 09 09 20 20 20 20 3b 3b 20 72 65 6c 65 61 73 ... ;; releas
82f0: 65 20 6c 6f 63 6b 20 68 65 72 65 0a 0a 09 09 20 e lock here....
8300: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
8310: 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 ! *db-multi-sync
8320: 2d 6d 75 74 65 78 2a 29 29 29 0a 09 20 20 20 20 -mutex*)))..
8330: 20 20 28 69 66 20 28 61 6e 64 20 64 65 62 75 67 (if (and debug
8340: 2d 6d 6f 64 65 0a 09 09 20 20 20 20 20 20 20 28 -mode... (
8350: 3e 20 28 2d 20 73 74 61 72 74 2d 74 69 6d 65 20 > (- start-time
8360: 6c 61 73 74 2d 74 69 6d 65 29 20 36 30 29 29 0a last-time) 60)).
8370: 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 .. (begin...
8380: 20 28 73 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 (set! last-time
8390: 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 09 09 20 start-time)...
83a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
83b0: 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
83c0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 69 6d 65 73 log-port* "times
83d0: 74 61 6d 70 20 2d 3e 20 22 20 28 73 65 63 6f 6e tamp -> " (secon
83e0: 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 ds->time-string
83f0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
8400: 29 29 20 22 2c 20 74 69 6d 65 20 73 69 6e 63 65 )) ", time since
8410: 20 73 74 61 72 74 20 2d 3e 20 22 20 28 73 65 63 start -> " (sec
8420: 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 onds->hr-min-sec
8430: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
8440: 6f 6e 64 73 29 20 2a 74 69 6d 65 2d 7a 65 72 6f onds) *time-zero
8450: 2a 29 29 29 29 29 29 0a 09 20 20 20 20 0a 09 20 *)))))).. ..
8460: 20 20 20 3b 3b 20 6b 65 65 70 20 67 6f 69 6e 67 ;; keep going
8470: 20 75 6e 6c 65 73 73 20 74 69 6d 65 20 74 6f 20 unless time to
8480: 65 78 69 74 0a 09 20 20 20 20 3b 3b 0a 09 20 20 exit.. ;;..
8490: 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 69 6d 65 (if (not *time
84a0: 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 09 28 6c 65 -to-exit*)...(le
84b0: 74 20 64 65 6c 61 79 2d 6c 6f 6f 70 20 28 28 63 t delay-loop ((c
84c0: 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 20 20 ount 0)).
84d0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 64 65 ;;(de
84e0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
84f0: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
8500: 6f 72 74 2a 20 22 64 65 6c 61 79 2d 6c 6f 6f 70 ort* "delay-loop
8510: 20 74 6f 70 3b 20 63 6f 75 6e 74 3d 22 63 6f 75 top; count="cou
8520: 6e 74 22 20 70 69 64 3d 22 28 63 75 72 72 65 6e nt" pid="(curren
8530: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 74 t-process-id)" t
8540: 68 69 73 2d 77 64 2d 6e 75 6d 3d 22 74 68 69 73 his-wd-num="this
8550: 2d 77 64 2d 6e 75 6d 22 20 2a 74 69 6d 65 2d 74 -wd-num" *time-t
8560: 6f 2d 65 78 69 74 2a 3d 22 2a 74 69 6d 65 2d 74 o-exit*="*time-t
8570: 6f 2d 65 78 69 74 2a 29 0a 20 20 20 20 20 20 20 o-exit*).
8580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85b0: 20 20 20 20 20 0a 09 09 20 20 28 69 66 20 28 61 ... (if (a
85c0: 6e 64 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f nd (not *time-to
85d0: 2d 65 78 69 74 2a 29 0a 09 09 09 20 20 20 28 3c -exit*).... (<
85e0: 20 63 6f 75 6e 74 20 36 29 29 20 3b 3b 20 77 61 count 6)) ;; wa
85f0: 73 20 31 31 2c 20 63 68 61 6e 67 69 6e 67 20 74 s 11, changing t
8600: 6f 20 34 2e 20 0a 09 09 20 20 20 20 20 20 28 62 o 4. ... (b
8610: 65 67 69 6e 0a 09 09 09 28 74 68 72 65 61 64 2d egin....(thread-
8620: 73 6c 65 65 70 21 20 31 29 0a 09 09 09 28 64 65 sleep! 1)....(de
8630: 6c 61 79 2d 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e lay-loop (+ coun
8640: 74 20 31 29 29 29 29 0a 09 09 20 20 28 69 66 20 t 1))))... (if
8650: 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 (not *time-to-ex
8660: 69 74 2a 29 20 28 6c 6f 6f 70 29 29 29 29 0a 09 it*) (loop))))..
8670: 20 20 20 20 3b 3b 20 74 69 6d 65 20 74 6f 20 65 ;; time to e
8680: 78 69 74 2c 20 63 6c 6f 73 65 20 74 68 65 20 6e xit, close the n
8690: 6f 2d 73 79 6e 63 20 64 62 20 68 65 72 65 0a 09 o-sync db here..
86a0: 20 20 20 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d (db:no-sync-
86b0: 63 6c 6f 73 65 2d 64 62 20 6e 6f 2d 73 79 6e 63 close-db no-sync
86c0: 2d 64 62 29 0a 09 20 20 20 20 28 69 66 20 28 63 -db).. (if (c
86d0: 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d ommon:low-noise-
86e0: 70 72 69 6e 74 20 33 30 29 0a 09 09 28 64 65 62 print 30)...(deb
86f0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
8700: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8710: 74 2a 20 22 45 78 69 74 69 6e 67 20 77 61 74 63 t* "Exiting watc
8720: 68 64 6f 67 20 74 69 6d 65 72 2c 20 2a 74 69 6d hdog timer, *tim
8730: 65 2d 74 6f 2d 65 78 69 74 2a 20 3d 20 22 20 2a e-to-exit* = " *
8740: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 22 20 70 time-to-exit*" p
8750: 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f id="(current-pro
8760: 63 65 73 73 2d 69 64 29 20 29 29 29 29 29 29 29 cess-id) )))))))
8770: 20 3b 3b 22 20 74 68 69 73 2d 77 64 2d 6e 75 6d ;;" this-wd-num
8780: 3d 22 74 68 69 73 2d 77 64 2d 6e 75 6d 29 29 29 ="this-wd-num)))
8790: 29 29 29 29 0a 0a ))))..