Artifact
af3a7f7873fe257aedd5e0b8478efab18dcf3d4d:
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 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 28 72 65 71 75 PURPOSE...(requ
0150: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
0160: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
0170: 63 70 20 73 31 31 6e 29 0a 0a 28 75 73 65 20 73 cp s11n)..(use s
0180: 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 rfi-1 posix rege
0190: 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 x regex-case srf
01a0: 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d 64 i-69 hostinfo md
01b0: 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 5 message-digest
01c0: 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 directory-utils
01d0: 20 70 6f 73 69 78 2d 65 78 74 72 61 73 20 6d 61 posix-extras ma
01e0: 74 63 68 61 62 6c 65 29 0a 3b 3b 20 28 75 73 65 tchable).;; (use
01f0: 20 7a 6d 71 29 0a 0a 28 75 73 65 20 73 70 69 66 zmq)..(use spif
0200: 66 79 20 75 72 69 2d 63 6f 6d 6d 6f 6e 20 69 6e fy uri-common in
0210: 74 61 72 77 65 62 20 68 74 74 70 2d 63 6c 69 65 tarweb http-clie
0220: 6e 74 20 73 70 69 66 66 79 2d 72 65 71 75 65 73 nt spiffy-reques
0230: 74 2d 76 61 72 73 29 0a 0a 28 64 65 63 6c 61 72 t-vars)..(declar
0240: 65 20 28 75 6e 69 74 20 73 65 72 76 65 72 29 29 e (unit server))
0250: 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ..(declare (uses
0260: 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 common)).(decla
0270: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0280: 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 61 73 eclare (uses tas
0290: 6b 73 29 29 20 3b 3b 20 74 61 73 6b 73 20 61 72 ks)) ;; tasks ar
02a0: 65 20 77 68 65 72 65 20 73 74 75 66 66 20 69 73 e where stuff is
02b0: 20 6d 61 69 6e 74 61 69 6e 65 64 20 61 62 6f 75 maintained abou
02c0: 74 20 77 68 61 74 20 69 73 20 72 75 6e 6e 69 6e t what is runnin
02d0: 67 2e 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 g..;; (declare (
02e0: 75 73 65 73 20 73 79 6e 63 68 61 73 68 29 29 0a uses synchash)).
02f0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 68 (declare (uses h
0300: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a ttp-transport)).
0310: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 72 (declare (uses r
0320: 70 63 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a 3b pc-transport)).;
0330: 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 ;(declare (uses
0340: 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 29 29 nmsg-transport))
0350: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0360: 6c 61 75 6e 63 68 29 29 0a 28 64 65 63 6c 61 72 launch)).(declar
0370: 65 20 28 75 73 65 73 20 64 61 65 6d 6f 6e 29 29 e (uses daemon))
0380: 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d ..(include "comm
0390: 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 on_records.scm")
03a0: 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 .(include "db_re
03b0: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 64 65 cords.scm")..(de
03c0: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6d 61 6b fine (server:mak
03d0: 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 68 6f 73 e-server-url hos
03e0: 74 70 6f 72 74 29 0a 20 20 28 69 66 20 28 6e 6f tport). (if (no
03f0: 74 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 20 20 t hostport).
0400: 20 20 23 66 0a 20 20 20 20 20 20 28 63 6f 6e 63 #f. (conc
0410: 20 22 68 74 74 70 3a 2f 2f 22 20 28 63 61 72 20 "http://" (car
0420: 68 6f 73 74 70 6f 72 74 29 20 22 3a 22 20 28 63 hostport) ":" (c
0430: 61 64 72 20 68 6f 73 74 70 6f 72 74 29 29 29 29 adr hostport))))
0440: 0a 0a 28 64 65 66 69 6e 65 20 20 2a 73 65 72 76 ..(define *serv
0450: 65 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 2d 62 65 er-loop-heart-be
0460: 61 74 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 at* (current-sec
0470: 6f 6e 64 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d onds))..;;======
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04c0: 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 0a .;; S E R V E R.
04d0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 43 61 6c ========..;; Cal
0520: 6c 20 74 68 69 73 20 74 6f 20 73 74 61 72 74 20 l this to start
0530: 74 68 65 20 61 63 74 75 61 6c 20 73 65 72 76 65 the actual serve
0540: 72 0a 3b 3b 0a 0a 3b 3b 20 61 6c 6c 20 72 6f 75 r.;;..;; all rou
0550: 74 65 73 20 74 68 6f 75 67 68 20 68 65 72 65 20 tes though here
0560: 65 6e 64 20 69 6e 20 65 78 69 74 20 2e 2e 2e 0a end in exit ....
0570: 3b 3b 0a 3b 3b 20 73 74 61 72 74 5f 73 65 72 76 ;;.;; start_serv
0580: 65 72 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 er.;;.(define (s
0590: 65 72 76 65 72 3a 6c 61 75 6e 63 68 20 72 75 6e erver:launch run
05a0: 2d 69 64 20 74 72 61 6e 73 70 6f 72 74 2d 74 79 -id transport-ty
05b0: 70 65 29 0a 20 20 28 63 61 73 65 20 74 72 61 6e pe). (case tran
05c0: 73 70 6f 72 74 2d 74 79 70 65 0a 20 20 20 20 28 sport-type. (
05d0: 28 68 74 74 70 29 28 68 74 74 70 2d 74 72 61 6e (http)(http-tran
05e0: 73 70 6f 72 74 3a 6c 61 75 6e 63 68 29 29 0a 20 sport:launch)).
05f0: 20 20 20 3b 3b 28 28 6e 6d 73 67 29 28 6e 6d 73 ;;((nmsg)(nms
0600: 67 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e g-transport:laun
0610: 63 68 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 ch run-id)).
0620: 28 28 72 70 63 29 20 20 28 72 70 63 2d 74 72 61 ((rpc) (rpc-tra
0630: 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 72 75 nsport:launch ru
0640: 6e 2d 69 64 29 29 0a 20 20 20 20 28 65 6c 73 65 n-id)). (else
0650: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
0660: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
0670: 6f 67 2d 70 6f 72 74 2a 20 22 75 6e 6b 6e 6f 77 og-port* "unknow
0680: 6e 20 73 65 72 76 65 72 20 74 79 70 65 20 22 20 n server type "
0690: 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 29 29 transport-type))
06a0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
06b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
06f0: 53 20 45 20 52 20 56 20 45 20 52 20 20 20 55 20 S E R V E R U
0700: 54 20 49 20 4c 20 49 20 54 20 49 20 45 20 53 20 T I L I T I E S
0710: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
0720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 =========..;; Ge
0760: 74 20 74 68 65 20 74 72 61 6e 73 70 6f 72 74 0a t the transport.
0770: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
0780: 67 65 74 2d 74 72 61 6e 73 70 6f 72 74 29 0a 20 get-transport).
0790: 20 28 69 66 20 2a 74 72 61 6e 73 70 6f 72 74 2d (if *transport-
07a0: 74 79 70 65 2a 0a 20 20 20 20 20 20 2a 74 72 61 type*. *tra
07b0: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 0a 20 20 20 nsport-type*.
07c0: 20 20 20 28 6c 65 74 20 28 28 74 74 79 70 65 20 (let ((ttype
07d0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 0a (string->symbol.
07e0: 09 09 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a .. (or (args:
07f0: 67 65 74 2d 61 72 67 20 22 2d 74 72 61 6e 73 70 get-arg "-transp
0800: 6f 72 74 22 29 0a 09 09 09 28 63 6f 6e 66 69 67 ort")....(config
0810: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
0820: 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 74 dat* "server" "t
0830: 72 61 6e 73 70 6f 72 74 22 29 0a 09 09 09 22 72 ransport")...."r
0840: 70 63 22 29 29 29 29 0a 09 28 73 65 74 21 20 2a pc"))))..(set! *
0850: 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 transport-type*
0860: 74 74 79 70 65 29 0a 09 74 74 79 70 65 29 29 29 ttype)..ttype)))
0870: 0a 09 20 20 20 20 0a 3b 3b 20 47 65 6e 65 72 61 .. .;; Genera
0880: 74 65 20 61 20 75 6e 69 71 75 65 20 73 69 67 6e te a unique sign
0890: 61 74 75 72 65 20 66 6f 72 20 74 68 69 73 20 73 ature for this s
08a0: 65 72 76 65 72 0a 28 64 65 66 69 6e 65 20 28 73 erver.(define (s
08b0: 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 erver:mk-signatu
08c0: 72 65 29 0a 20 20 28 6d 65 73 73 61 67 65 2d 64 re). (message-d
08d0: 69 67 65 73 74 2d 73 74 72 69 6e 67 20 28 6d 64 igest-string (md
08e0: 35 2d 70 72 69 6d 69 74 69 76 65 29 20 0a 09 09 5-primitive) ...
08f0: 09 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 . (with-output-t
0900: 6f 2d 73 74 72 69 6e 67 0a 09 09 09 20 20 20 28 o-string.... (
0910: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
0920: 20 20 28 77 72 69 74 65 20 28 6c 69 73 74 20 28 (write (list (
0930: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
0940: 79 29 0a 09 09 09 09 09 20 20 28 61 72 67 76 29 y)...... (argv)
0950: 29 29 29 29 29 29 0a 0a 3b 3b 20 57 68 65 6e 20 ))))))..;; When
0960: 75 73 69 6e 67 20 7a 6d 71 20 74 68 69 73 20 77 using zmq this w
0970: 6f 75 6c 64 20 73 65 6e 64 20 74 68 65 20 6d 65 ould send the me
0980: 73 73 61 67 65 20 62 61 63 6b 20 28 74 77 6f 20 ssage back (two
0990: 73 74 65 70 20 70 72 6f 63 65 73 73 29 0a 3b 3b step process).;;
09a0: 20 77 69 74 68 20 73 70 69 66 66 79 20 6f 72 20 with spiffy or
09b0: 72 70 63 20 74 68 69 73 20 73 69 6d 70 6c 79 20 rpc this simply
09c0: 72 65 74 75 72 6e 73 20 74 68 65 20 72 65 74 75 returns the retu
09d0: 72 6e 20 64 61 74 61 20 74 6f 20 62 65 20 72 65 rn data to be re
09e0: 74 75 72 6e 65 64 0a 3b 3b 20 0a 28 64 65 66 69 turned.;; .(defi
09f0: 6e 65 20 28 73 65 72 76 65 72 3a 72 65 70 6c 79 ne (server:reply
0a00: 20 72 65 74 75 72 6e 2d 61 64 64 72 20 71 75 65 return-addr que
0a10: 72 79 2d 73 69 67 20 73 75 63 63 65 73 73 2f 66 ry-sig success/f
0a20: 61 69 6c 20 72 65 73 75 6c 74 29 0a 20 20 28 64 ail result). (d
0a30: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
0a40: 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 11 *default-log-
0a50: 70 6f 72 74 2a 20 22 73 65 72 76 65 72 3a 72 65 port* "server:re
0a60: 70 6c 79 20 72 65 74 75 72 6e 2d 61 64 64 72 3d ply return-addr=
0a70: 22 20 72 65 74 75 72 6e 2d 61 64 64 72 20 22 2c " return-addr ",
0a80: 20 72 65 73 75 6c 74 3d 22 20 72 65 73 75 6c 74 result=" result
0a90: 29 0a 20 20 3b 3b 20 28 73 65 6e 64 2d 6d 65 73 ). ;; (send-mes
0aa0: 73 61 67 65 20 70 75 62 73 6f 63 6b 20 74 61 72 sage pubsock tar
0ab0: 67 65 74 20 73 65 6e 64 2d 6d 6f 72 65 3a 20 23 get send-more: #
0ac0: 74 29 0a 20 20 3b 3b 20 28 73 65 6e 64 2d 6d 65 t). ;; (send-me
0ad0: 73 73 61 67 65 20 70 75 62 73 6f 63 6b 20 0a 20 ssage pubsock .
0ae0: 20 28 63 61 73 65 20 28 73 65 72 76 65 72 3a 67 (case (server:g
0af0: 65 74 2d 74 72 61 6e 73 70 6f 72 74 29 0a 20 20 et-transport).
0b00: 20 20 28 28 72 70 63 29 20 20 28 64 62 3a 6f 62 ((rpc) (db:ob
0b10: 6a 2d 3e 73 74 72 69 6e 67 20 28 76 65 63 74 6f j->string (vecto
0b20: 72 20 73 75 63 63 65 73 73 2f 66 61 69 6c 20 71 r success/fail q
0b30: 75 65 72 79 2d 73 69 67 20 72 65 73 75 6c 74 29 uery-sig result)
0b40: 29 29 0a 20 20 20 20 28 28 68 74 74 70 29 20 28 )). ((http) (
0b50: 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 28 db:obj->string (
0b60: 76 65 63 74 6f 72 20 73 75 63 63 65 73 73 2f 66 vector success/f
0b70: 61 69 6c 20 71 75 65 72 79 2d 73 69 67 20 72 65 ail query-sig re
0b80: 73 75 6c 74 29 29 29 0a 20 20 20 20 28 28 66 73 sult))). ((fs
0b90: 29 20 20 20 72 65 73 75 6c 74 29 0a 20 20 20 20 ) result).
0ba0: 28 65 6c 73 65 20 0a 20 20 20 20 20 28 64 65 62 (else . (deb
0bb0: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
0bc0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
0bd0: 72 74 2a 20 22 75 6e 72 65 63 6f 67 6e 69 73 65 rt* "unrecognise
0be0: 64 20 74 72 61 6e 73 70 6f 72 74 20 74 79 70 65 d transport type
0bf0: 3a 20 22 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 : " *transport-t
0c00: 79 70 65 2a 29 0a 20 20 20 20 20 72 65 73 75 6c ype*). resul
0c10: 74 29 29 29 0a 0a 3b 3b 20 47 69 76 65 6e 20 61 t)))..;; Given a
0c20: 20 72 75 6e 20 69 64 20 73 74 61 72 74 20 61 20 run id start a
0c30: 73 65 72 76 65 72 20 70 72 6f 63 65 73 73 20 20 server process
0c40: 20 20 23 23 23 20 4e 4f 54 45 20 23 23 23 20 3e ### NOTE ### >
0c50: 20 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 69 file 2>&1 .;; i
0c60: 66 20 74 68 65 20 72 75 6e 2d 69 64 20 69 73 20 f the run-id is
0c70: 7a 65 72 6f 20 61 6e 64 20 74 68 65 20 74 61 72 zero and the tar
0c80: 67 65 74 2d 68 6f 73 74 20 69 73 20 73 65 74 20 get-host is set
0c90: 0a 3b 3b 20 74 72 79 20 72 75 6e 6e 69 6e 67 20 .;; try running
0ca0: 6f 6e 20 74 68 61 74 20 68 6f 73 74 0a 3b 3b 20 on that host.;;
0cb0: 20 20 69 6e 63 69 64 65 6e 74 61 6c 3a 20 72 6f incidental: ro
0cc0: 74 61 74 65 20 6c 6f 67 73 20 69 6e 20 6c 6f 67 tate logs in log
0cd0: 73 2f 20 64 69 72 2e 0a 3b 3b 0a 28 64 65 66 69 s/ dir..;;.(defi
0ce0: 6e 65 20 20 28 73 65 72 76 65 72 3a 72 75 6e 20 ne (server:run
0cf0: 61 72 65 61 70 61 74 68 29 20 3b 3b 20 61 72 65 areapath) ;; are
0d00: 61 70 61 74 68 20 69 73 20 2a 74 6f 70 70 61 74 apath is *toppat
0d10: 68 2a 20 66 6f 72 20 61 20 67 69 76 65 6e 20 74 h* for a given t
0d20: 65 73 74 73 75 69 74 65 20 61 72 65 61 0a 20 20 estsuite area.
0d30: 28 6c 65 74 2a 20 28 28 63 75 72 72 2d 68 6f 73 (let* ((curr-hos
0d40: 74 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 t (get-host-na
0d50: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 3b 3b me)). ;;
0d60: 20 28 61 74 74 65 6d 70 74 2d 69 6e 2d 70 72 6f (attempt-in-pro
0d70: 67 72 65 73 73 20 28 73 65 72 76 65 72 3a 73 74 gress (server:st
0d80: 61 72 74 2d 61 74 74 65 6d 70 74 65 64 3f 20 61 art-attempted? a
0d90: 72 65 61 70 61 74 68 29 29 0a 20 20 20 20 20 20 reapath)).
0da0: 20 20 20 3b 3b 20 28 64 6f 74 2d 73 65 72 76 65 ;; (dot-serve
0db0: 72 2d 75 72 6c 20 28 73 65 72 76 65 72 3a 63 68 r-url (server:ch
0dc0: 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 eck-if-running a
0dd0: 72 65 61 70 61 74 68 29 29 0a 09 20 28 63 75 72 reapath)).. (cur
0de0: 72 2d 69 70 20 20 20 20 20 28 73 65 72 76 65 72 r-ip (server
0df0: 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d :get-best-guess-
0e00: 61 64 64 72 65 73 73 20 63 75 72 72 2d 68 6f 73 address curr-hos
0e10: 74 29 29 0a 09 20 28 63 75 72 72 2d 70 69 64 20 t)).. (curr-pid
0e20: 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 (current-proc
0e30: 65 73 73 2d 69 64 29 29 0a 09 20 28 68 6f 6d 65 ess-id)).. (home
0e40: 68 6f 73 74 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a host (common:
0e50: 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 20 3b get-homehost)) ;
0e60: 3b 20 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 ; configf:lookup
0e70: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
0e80: 72 76 65 72 22 20 22 68 6f 6d 65 68 6f 73 74 22 rver" "homehost"
0e90: 20 29 29 0a 09 20 28 74 61 72 67 65 74 2d 68 6f )).. (target-ho
0ea0: 73 74 20 28 63 61 72 20 68 6f 6d 65 68 6f 73 74 st (car homehost
0eb0: 29 29 0a 09 20 28 74 65 73 74 73 75 69 74 65 20 )).. (testsuite
0ec0: 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 (common:get-te
0ed0: 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 stsuite-name))..
0ee0: 20 28 6c 6f 67 66 69 6c 65 20 20 20 20 20 28 63 (logfile (c
0ef0: 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f 6c onc areapath "/l
0f00: 6f 67 73 2f 73 65 72 76 65 72 2e 6c 6f 67 22 29 ogs/server.log")
0f10: 29 20 3b 3b 20 2d 22 20 63 75 72 72 2d 70 69 64 ) ;; -" curr-pid
0f20: 20 22 2d 22 20 74 61 72 67 65 74 2d 68 6f 73 74 "-" target-host
0f30: 20 22 2e 6c 6f 67 22 29 29 0a 09 20 28 63 6d 64 ".log")).. (cmd
0f40: 6c 6e 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e ln (conc (common
0f50: 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 :get-megatest-ex
0f60: 65 29 0a 09 09 20 20 20 20 20 20 22 20 2d 73 65 e)... " -se
0f70: 72 76 65 72 20 22 20 28 6f 72 20 74 61 72 67 65 rver " (or targe
0f80: 74 2d 68 6f 73 74 20 22 2d 22 29 20 28 69 66 20 t-host "-") (if
0f90: 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 (equal? (configf
0fa0: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
0fb0: 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 64 61 at* "server" "da
0fc0: 65 6d 6f 6e 69 7a 65 22 29 20 22 79 65 73 22 29 emonize") "yes")
0fd0: 0a 09 09 09 09 09 09 09 20 20 20 22 20 2d 64 61 ........ " -da
0fe0: 65 6d 6f 6e 69 7a 65 20 22 0a 09 09 09 09 09 09 emonize ".......
0ff0: 09 20 20 20 22 22 29 0a 09 09 20 20 20 20 20 20 . "")...
1000: 3b 3b 20 22 20 2d 6c 6f 67 20 22 20 6c 6f 67 66 ;; " -log " logf
1010: 69 6c 65 0a 09 09 20 20 20 20 20 20 22 20 2d 6d ile... " -m
1020: 20 74 65 73 74 73 75 69 74 65 3a 22 20 74 65 73 testsuite:" tes
1030: 74 73 75 69 74 65 29 29 20 3b 3b 20 28 63 6f 6e tsuite)) ;; (con
1040: 63 20 22 20 3e 3e 20 22 20 6c 6f 67 66 69 6c 65 c " >> " logfile
1050: 20 22 20 32 3e 26 31 20 26 22 29 29 29 29 29 0a " 2>&1 &"))))).
1060: 09 20 28 6c 6f 67 2d 72 6f 74 61 74 65 20 20 28 . (log-rotate (
1070: 6d 61 6b 65 2d 74 68 72 65 61 64 20 63 6f 6d 6d make-thread comm
1080: 6f 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 20 20 on:rotate-logs
1090: 22 73 65 72 76 65 72 20 72 75 6e 2c 20 72 6f 74 "server run, rot
10a0: 61 74 65 20 6c 6f 67 73 20 74 68 72 65 61 64 22 ate logs thread"
10b0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 )). (loa
10c0: 64 2d 6c 69 6d 69 74 20 20 28 63 6f 6e 66 69 67 d-limit (config
10d0: 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 65 72 20 f:lookup-number
10e0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 *configdat* "ser
10f0: 76 65 72 22 20 22 6c 6f 61 64 2d 6c 69 6d 69 74 ver" "load-limit
1100: 22 20 64 65 66 61 75 6c 74 3a 20 30 2e 39 29 29 " default: 0.9))
1110: 29 0a 20 20 20 20 3b 3b 20 77 65 20 77 61 6e 74 ). ;; we want
1120: 20 74 68 65 20 72 65 6d 6f 74 65 20 73 65 72 76 the remote serv
1130: 65 72 20 74 6f 20 73 74 61 72 74 20 69 6e 20 2a er to start in *
1140: 74 6f 70 70 61 74 68 2a 20 73 6f 20 70 75 73 68 toppath* so push
1150: 20 74 68 65 72 65 0a 20 20 20 20 28 70 75 73 68 there. (push
1160: 2d 64 69 72 65 63 74 6f 72 79 20 61 72 65 61 70 -directory areap
1170: 61 74 68 29 0a 20 20 20 20 28 64 65 62 75 67 3a ath). (debug:
1180: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
1190: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
11a0: 3a 20 54 72 79 69 6e 67 20 74 6f 20 73 74 61 72 : Trying to star
11b0: 74 20 73 65 72 76 65 72 20 28 22 20 63 6d 64 6c t server (" cmdl
11c0: 6e 20 22 29 20 2e 2e 2e 22 29 0a 20 20 20 20 28 n ") ..."). (
11d0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 6c 6f thread-start! lo
11e0: 67 2d 72 6f 74 61 74 65 29 0a 20 20 20 20 0a 20 g-rotate). .
11f0: 20 20 20 3b 3b 20 68 6f 73 74 2e 64 6f 6d 61 69 ;; host.domai
1200: 6e 2e 74 6c 64 20 6d 61 74 63 68 20 68 6f 73 74 n.tld match host
1210: 3f 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 74 ?. (if (and t
1220: 61 72 67 65 74 2d 68 6f 73 74 20 0a 09 20 20 20 arget-host ..
1230: 20 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 61 72 ;; look at tar
1240: 67 65 74 20 68 6f 73 74 2c 20 69 73 20 69 74 20 get host, is it
1250: 68 6f 73 74 2e 64 6f 6d 61 69 6e 2e 74 6c 64 20 host.domain.tld
1260: 6f 72 20 69 70 20 61 64 64 72 65 73 73 20 61 6e or ip address an
1270: 64 20 64 6f 65 73 20 69 74 20 0a 09 20 20 20 20 d does it ..
1280: 20 3b 3b 20 6d 61 74 63 68 20 63 75 72 72 65 6e ;; match curren
1290: 74 20 69 70 20 6f 72 20 68 6f 73 74 6e 61 6d 65 t ip or hostname
12a0: 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 73 74 72 .. (not (str
12b0: 69 6e 67 2d 6d 61 74 63 68 20 28 63 6f 6e 63 20 ing-match (conc
12c0: 22 28 22 63 75 72 72 2d 68 6f 73 74 20 22 7c 22 "("curr-host "|"
12d0: 20 63 75 72 72 2d 68 6f 73 74 22 5c 5c 2e 2e 2a curr-host"\\..*
12e0: 29 22 29 20 74 61 72 67 65 74 2d 68 6f 73 74 29 )") target-host)
12f0: 29 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 65 71 ).. (not (eq
1300: 75 61 6c 3f 20 63 75 72 72 2d 69 70 20 74 61 72 ual? curr-ip tar
1310: 67 65 74 2d 68 6f 73 74 29 29 29 0a 09 28 62 65 get-host)))..(be
1320: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
1330: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
1340: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
1350: 74 61 72 74 69 6e 67 20 73 65 72 76 65 72 20 6f tarting server o
1360: 6e 20 22 20 74 61 72 67 65 74 2d 68 6f 73 74 20 n " target-host
1370: 22 2c 20 6c 6f 67 66 69 6c 65 20 69 73 20 22 20 ", logfile is "
1380: 6c 6f 67 66 69 6c 65 29 0a 09 20 20 28 73 65 74 logfile).. (set
1390: 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 env "TARGETHOST"
13a0: 20 74 61 72 67 65 74 2d 68 6f 73 74 29 29 29 0a target-host))).
13b0: 20 20 20 20 20 20 0a 20 20 20 20 28 73 65 74 65 . (sete
13c0: 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 5f 4c nv "TARGETHOST_L
13d0: 4f 47 46 22 20 6c 6f 67 66 69 6c 65 29 0a 20 20 OGF" logfile).
13e0: 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 (common:wait-f
13f0: 6f 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 6c 6f or-normalized-lo
1400: 61 64 20 6c 6f 61 64 2d 6c 69 6d 69 74 20 22 20 ad load-limit "
1410: 64 65 6c 61 79 69 6e 67 20 73 65 72 76 65 72 20 delaying server
1420: 73 74 61 72 74 20 64 75 65 20 74 6f 20 6c 6f 61 start due to loa
1430: 64 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 3a 20 d" remote-host:
1440: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
1450: 2d 76 61 72 69 61 62 6c 65 20 22 54 41 52 47 45 -variable "TARGE
1460: 54 48 4f 53 54 22 29 29 20 3b 3b 20 64 6f 20 6e THOST")) ;; do n
1470: 6f 74 20 74 72 79 20 73 74 61 72 74 69 6e 67 20 ot try starting
1480: 73 65 72 76 65 72 73 20 6f 6e 20 61 6e 20 61 6c servers on an al
1490: 72 65 61 64 79 20 6f 76 65 72 6c 6f 61 64 65 64 ready overloaded
14a0: 20 6d 61 63 68 69 6e 65 2c 20 6a 75 73 74 20 77 machine, just w
14b0: 61 69 74 20 66 6f 72 65 76 65 72 0a 20 20 20 20 ait forever.
14c0: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6e (system (conc "n
14d0: 62 66 61 6b 65 20 22 20 63 6d 64 6c 6e 29 29 0a bfake " cmdln)).
14e0: 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 54 (unsetenv "T
14f0: 41 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 29 ARGETHOST_LOGF")
1500: 0a 20 20 20 20 28 69 66 20 28 67 65 74 2d 65 6e . (if (get-en
1510: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
1520: 6c 65 20 22 54 41 52 47 45 54 48 4f 53 54 22 29 le "TARGETHOST")
1530: 28 75 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 (unsetenv "TARGE
1540: 54 48 4f 53 54 22 29 29 0a 20 20 20 20 28 74 68 THOST")). (th
1550: 72 65 61 64 2d 6a 6f 69 6e 21 20 6c 6f 67 2d 72 read-join! log-r
1560: 6f 74 61 74 65 29 0a 20 20 20 20 28 70 6f 70 2d otate). (pop-
1570: 64 69 72 65 63 74 6f 72 79 29 29 29 0a 0a 3b 3b directory)))..;;
1580: 20 67 69 76 65 6e 20 61 20 70 61 74 68 20 74 6f given a path to
1590: 20 61 20 73 65 72 76 65 72 20 6c 6f 67 20 72 65 a server log re
15a0: 74 75 72 6e 3a 20 68 6f 73 74 20 70 6f 72 74 20 turn: host port
15b0: 73 74 61 72 74 73 65 63 6f 6e 64 73 0a 3b 3b 0a startseconds.;;.
15c0: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
15d0: 6c 6f 67 66 2d 67 65 74 2d 73 74 61 72 74 2d 69 logf-get-start-i
15e0: 6e 66 6f 20 6c 6f 67 66 29 0a 20 20 28 6c 65 74 nfo logf). (let
15f0: 20 28 28 72 78 20 28 72 65 67 65 78 70 20 22 5e ((rx (regexp "^
1600: 53 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 SERVER STARTED:
1610: 28 5c 5c 53 2b 29 3a 28 5c 5c 64 2b 29 20 41 54 (\\S+):(\\d+) AT
1620: 20 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 22 29 29 29 ([\\d\\.]+)")))
1630: 20 3b 3b 20 53 45 52 56 45 52 20 53 54 41 52 54 ;; SERVER START
1640: 45 44 3a 20 68 6f 73 74 3a 70 6f 72 74 20 41 54 ED: host:port AT
1650: 20 74 69 6d 65 73 65 63 73 0a 20 20 20 20 28 68 timesecs. (h
1660: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
1670: 0a 09 65 78 6e 0a 09 28 6c 69 73 74 20 23 66 20 ..exn..(list #f
1680: 23 66 20 23 66 29 20 3b 3b 20 6e 6f 20 69 64 65 #f #f) ;; no ide
1690: 61 20 77 68 61 74 20 77 65 6e 74 20 77 72 6f 6e a what went wron
16a0: 67 2c 20 63 61 6c 6c 20 69 74 20 61 20 62 61 64 g, call it a bad
16b0: 20 73 65 72 76 65 72 0a 20 20 20 20 20 20 28 77 server. (w
16c0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
16d0: 69 6c 65 0a 09 20 20 6c 6f 67 66 0a 09 28 6c 61 ile.. logf..(la
16e0: 6d 62 64 61 20 28 29 0a 09 20 20 28 6c 65 74 20 mbda ().. (let
16f0: 6c 6f 6f 70 20 28 28 69 6e 6c 20 20 28 72 65 61 loop ((inl (rea
1700: 64 2d 6c 69 6e 65 29 29 0a 09 09 20 20 20 20 20 d-line))...
1710: 28 6c 6e 75 6d 20 30 29 29 0a 09 20 20 20 20 28 (lnum 0)).. (
1720: 69 66 20 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a if (not (eof-obj
1730: 65 63 74 3f 20 69 6e 6c 29 29 0a 09 09 28 6c 65 ect? inl))...(le
1740: 74 20 28 28 6d 6c 73 74 20 28 73 74 72 69 6e 67 t ((mlst (string
1750: 2d 6d 61 74 63 68 20 72 78 20 69 6e 6c 29 29 29 -match rx inl)))
1760: 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 6d 6c ... (if (not ml
1770: 73 74 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 st)... (if
1780: 28 3c 20 6c 6e 75 6d 20 35 30 30 29 20 3b 3b 20 (< lnum 500) ;;
1790: 67 69 76 65 20 75 70 20 69 66 20 6d 6f 72 65 20 give up if more
17a0: 74 68 61 6e 20 35 30 30 20 6c 69 6e 65 73 20 6f than 500 lines o
17b0: 66 20 73 65 72 76 65 72 20 6c 6f 67 20 72 65 61 f server log rea
17c0: 64 0a 09 09 09 20 20 28 6c 6f 6f 70 20 28 72 65 d.... (loop (re
17d0: 61 64 2d 6c 69 6e 65 29 28 2b 20 6c 6e 75 6d 20 ad-line)(+ lnum
17e0: 31 29 29 0a 09 09 09 20 20 28 6c 69 73 74 20 23 1)).... (list #
17f0: 66 20 23 66 20 23 66 29 29 0a 09 09 20 20 20 20 f #f #f))...
1800: 20 20 28 6c 65 74 20 28 28 64 61 74 20 20 28 63 (let ((dat (c
1810: 64 72 20 6d 6c 73 74 29 29 29 0a 09 09 09 28 6c dr mlst)))....(l
1820: 69 73 74 20 28 63 61 72 20 64 61 74 29 20 3b 3b ist (car dat) ;;
1830: 20 68 6f 73 74 0a 09 09 09 20 20 20 20 20 20 28 host.... (
1840: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
1850: 63 61 64 72 20 64 61 74 29 29 20 3b 3b 20 70 6f cadr dat)) ;; po
1860: 72 74 0a 09 09 09 20 20 20 20 20 20 28 73 74 72 rt.... (str
1870: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 ing->number (cad
1880: 64 72 20 64 61 74 29 29 29 29 29 29 0a 09 09 28 dr dat))))))...(
1890: 6c 69 73 74 20 23 66 20 23 66 20 23 66 29 29 29 list #f #f #f)))
18a0: 29 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 61 20 )))))..;; get a
18b0: 6c 69 73 74 20 6f 66 20 73 65 72 76 65 72 73 20 list of servers
18c0: 77 69 74 68 20 61 6c 6c 20 72 65 6c 65 76 61 6e with all relevan
18d0: 74 20 64 61 74 61 0a 3b 3b 20 28 20 6d 6f 64 2d t data.;; ( mod-
18e0: 74 69 6d 65 20 68 6f 73 74 20 70 6f 72 74 20 73 time host port s
18f0: 74 61 72 74 2d 74 69 6d 65 20 70 69 64 20 29 0a tart-time pid ).
1900: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 ;;.(define (serv
1910: 65 72 3a 67 65 74 2d 6c 69 73 74 20 61 72 65 61 er:get-list area
1920: 70 61 74 68 20 23 21 6b 65 79 20 28 6c 69 6d 69 path #!key (limi
1930: 74 20 23 66 29 29 0a 20 20 28 6c 65 74 20 28 28 t #f)). (let ((
1940: 66 6e 61 6d 65 2d 72 78 20 20 20 20 28 72 65 67 fname-rx (reg
1950: 65 78 70 20 22 5e 28 7c 2e 2a 2f 29 73 65 72 76 exp "^(|.*/)serv
1960: 65 72 2d 28 5c 5c 64 2b 29 2d 28 5c 5c 53 2b 29 er-(\\d+)-(\\S+)
1970: 2e 6c 6f 67 24 22 29 29 0a 09 28 64 61 79 2d 73 .log$"))..(day-s
1980: 65 63 6f 6e 64 73 20 28 2a 20 32 34 20 36 30 20 econds (* 24 60
1990: 36 30 29 29 29 0a 20 20 20 20 3b 3b 20 69 66 20 60))). ;; if
19a0: 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 65 78 the directory ex
19b0: 69 73 74 73 20 63 6f 6e 74 69 6e 75 65 20 74 6f ists continue to
19c0: 20 67 65 74 20 74 68 65 20 6c 69 73 74 0a 20 20 get the list.
19d0: 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 61 ;; otherwise a
19e0: 74 74 65 6d 70 74 20 74 6f 20 63 72 65 61 74 65 ttempt to create
19f0: 20 74 68 65 20 6c 6f 67 73 20 64 69 72 20 61 6e the logs dir an
1a00: 64 20 74 68 65 6e 0a 20 20 20 20 3b 3b 20 63 6f d then. ;; co
1a10: 6e 74 69 6e 75 65 0a 20 20 20 20 28 69 66 20 28 ntinue. (if (
1a20: 69 66 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 if (directory-ex
1a30: 69 73 74 73 3f 20 28 63 6f 6e 63 20 61 72 65 61 ists? (conc area
1a40: 70 61 74 68 20 22 2f 6c 6f 67 73 22 29 29 0a 09 path "/logs"))..
1a50: 20 20 20 20 27 28 29 0a 09 20 20 20 20 28 69 66 '().. (if
1a60: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
1a70: 65 73 73 3f 20 61 72 65 61 70 61 74 68 29 0a 09 ess? areapath)..
1a80: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 63 6f 6e .(begin... (con
1a90: 64 69 74 69 6f 6e 2d 63 61 73 65 0a 09 09 20 20 dition-case...
1aa0: 20 20 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 (create-dire
1ab0: 63 74 6f 72 79 20 28 63 6f 6e 63 20 61 72 65 61 ctory (conc area
1ac0: 70 61 74 68 20 22 2f 6c 6f 67 73 22 29 20 23 74 path "/logs") #t
1ad0: 29 0a 09 09 20 20 20 20 28 65 78 6e 20 28 69 2f )... (exn (i/
1ae0: 6f 20 66 69 6c 65 29 28 64 65 62 75 67 3a 70 72 o file)(debug:pr
1af0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
1b00: 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
1b10: 20 43 61 6e 6e 6f 74 20 63 72 65 61 74 65 20 64 Cannot create d
1b20: 69 72 65 63 74 6f 72 79 20 61 74 20 22 20 28 63 irectory at " (c
1b30: 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f 6c onc areapath "/l
1b40: 6f 67 73 22 29 29 29 0a 09 09 20 20 20 20 28 65 ogs")))... (e
1b50: 78 6e 20 28 29 28 64 65 62 75 67 3a 70 72 69 6e xn ()(debug:prin
1b60: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
1b70: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 55 -port* "ERROR: U
1b80: 6e 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 61 74 74 nknown error att
1b90: 65 6d 74 70 69 6e 67 20 74 6f 20 67 65 74 20 73 emtping to get s
1ba0: 65 72 76 65 72 20 6c 69 73 74 2e 22 29 29 29 0a erver list."))).
1bb0: 09 09 20 20 28 64 69 72 65 63 74 6f 72 79 2d 65 .. (directory-e
1bc0: 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 61 72 65 xists? (conc are
1bd0: 61 70 61 74 68 20 22 2f 6c 6f 67 73 22 29 29 29 apath "/logs")))
1be0: 0a 09 09 27 28 29 29 29 0a 09 28 6c 65 74 2a 20 ...'()))..(let*
1bf0: 28 28 73 65 72 76 65 72 2d 6c 6f 67 73 20 20 20 ((server-logs
1c00: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 61 72 65 61 (glob (conc area
1c10: 70 61 74 68 20 22 2f 6c 6f 67 73 2f 73 65 72 76 path "/logs/serv
1c20: 65 72 2d 2a 2e 6c 6f 67 22 29 29 29 0a 09 20 20 er-*.log")))..
1c30: 20 20 20 20 20 28 6e 75 6d 2d 73 65 72 76 2d 6c (num-serv-l
1c40: 6f 67 73 20 28 6c 65 6e 67 74 68 20 73 65 72 76 ogs (length serv
1c50: 65 72 2d 6c 6f 67 73 29 29 29 0a 09 20 20 28 69 er-logs))).. (i
1c60: 66 20 28 6e 75 6c 6c 3f 20 73 65 72 76 65 72 2d f (null? server-
1c70: 6c 6f 67 73 29 0a 09 20 20 20 20 20 20 27 28 29 logs).. '()
1c80: 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f .. (let loo
1c90: 70 20 28 28 68 65 64 20 20 28 63 61 72 20 73 65 p ((hed (car se
1ca0: 72 76 65 72 2d 6c 6f 67 73 29 29 0a 09 09 09 20 rver-logs))....
1cb0: 28 74 61 6c 20 20 28 63 64 72 20 73 65 72 76 65 (tal (cdr serve
1cc0: 72 2d 6c 6f 67 73 29 29 0a 09 09 09 20 28 72 65 r-logs)).... (re
1cd0: 73 20 27 28 29 29 29 0a 09 09 28 6c 65 74 2a 20 s '()))...(let*
1ce0: 28 28 6d 6f 64 2d 74 69 6d 65 20 20 28 68 61 6e ((mod-time (han
1cf0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
1d00: 09 09 09 20 20 20 20 20 20 65 78 6e 0a 09 09 09 ... exn....
1d10: 09 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d . (current-
1d20: 73 65 63 6f 6e 64 73 29 20 3b 3b 20 30 0a 09 09 seconds) ;; 0...
1d30: 09 09 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 .. (file-modi
1d40: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 68 65 fication-time he
1d50: 64 29 29 29 20 3b 3b 20 64 65 66 61 75 6c 74 20 d))) ;; default
1d60: 74 6f 20 2a 76 65 72 79 2a 20 6f 6c 64 20 73 6f to *very* old so
1d70: 20 6c 6f 67 20 67 65 74 73 20 69 67 6e 6f 72 65 log gets ignore
1d80: 64 20 69 66 20 64 65 6c 65 74 65 64 0a 09 09 20 d if deleted...
1d90: 20 20 20 20 20 20 28 64 6f 77 6e 2d 74 69 6d 65 (down-time
1da0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
1db0: 6f 6e 64 73 29 20 6d 6f 64 2d 74 69 6d 65 29 29 onds) mod-time))
1dc0: 0a 09 09 20 20 20 20 20 20 20 28 73 65 72 76 2d ... (serv-
1dd0: 64 61 74 20 20 28 69 66 20 28 6f 72 20 28 3c 20 dat (if (or (<
1de0: 6e 75 6d 2d 73 65 72 76 2d 6c 6f 67 73 20 31 30 num-serv-logs 10
1df0: 29 0a 09 09 09 09 20 20 09 20 20 28 3c 20 64 6f )..... . (< do
1e00: 77 6e 2d 74 69 6d 65 20 39 30 30 29 29 20 3b 3b wn-time 900)) ;;
1e10: 20 64 61 79 2d 73 65 63 6f 6e 64 73 29 29 0a 09 day-seconds))..
1e20: 09 09 09 20 20 20 20 20 20 28 73 65 72 76 65 72 ... (server
1e30: 3a 6c 6f 67 66 2d 67 65 74 2d 73 74 61 72 74 2d :logf-get-start-
1e40: 69 6e 66 6f 20 68 65 64 29 0a 09 09 09 09 20 20 info hed).....
1e50: 20 20 20 20 27 28 29 29 29 20 3b 3b 20 64 6f 6e '())) ;; don
1e60: 27 74 20 77 61 73 74 65 20 74 69 6d 65 20 70 72 't waste time pr
1e70: 6f 63 65 73 73 69 6e 67 20 73 65 72 76 65 72 20 ocessing server
1e80: 66 69 6c 65 73 20 6e 6f 74 20 74 6f 75 63 68 65 files not touche
1e90: 64 20 69 6e 20 74 68 65 20 31 35 20 6d 69 6e 75 d in the 15 minu
1ea0: 74 65 73 20 69 66 20 74 68 65 72 65 20 61 72 65 tes if there are
1eb0: 20 6d 6f 72 65 20 74 68 61 6e 20 74 65 6e 20 73 more than ten s
1ec0: 65 72 76 65 72 73 20 74 6f 20 6c 6f 6f 6b 20 61 ervers to look a
1ed0: 74 0a 09 09 20 20 20 20 20 20 20 28 73 65 72 76 t... (serv
1ee0: 2d 72 65 63 20 28 63 6f 6e 73 20 6d 6f 64 2d 74 -rec (cons mod-t
1ef0: 69 6d 65 20 73 65 72 76 2d 64 61 74 29 29 0a 09 ime serv-dat))..
1f00: 09 20 20 20 20 20 20 20 28 66 6d 61 74 63 68 20 . (fmatch
1f10: 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 (string-match
1f20: 66 6e 61 6d 65 2d 72 78 20 68 65 64 29 29 0a 09 fname-rx hed))..
1f30: 09 20 20 20 20 20 20 20 28 70 69 64 20 20 20 20 . (pid
1f40: 20 20 28 69 66 20 66 6d 61 74 63 68 20 28 73 74 (if fmatch (st
1f50: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6c 69 ring->number (li
1f60: 73 74 2d 72 65 66 20 66 6d 61 74 63 68 20 32 29 st-ref fmatch 2)
1f70: 29 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 20 ) #f))...
1f80: 28 6e 65 77 2d 72 65 73 20 20 28 69 66 20 28 6e (new-res (if (n
1f90: 75 6c 6c 3f 20 73 65 72 76 2d 64 61 74 29 0a 09 ull? serv-dat)..
1fa0: 09 09 09 20 20 20 20 20 72 65 73 0a 09 09 09 09 ... res.....
1fb0: 20 20 20 20 20 28 63 6f 6e 73 20 28 61 70 70 65 (cons (appe
1fc0: 6e 64 20 73 65 72 76 2d 72 65 63 20 28 6c 69 73 nd serv-rec (lis
1fd0: 74 20 70 69 64 29 29 20 72 65 73 29 29 29 29 0a t pid)) res)))).
1fe0: 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c ..(if (null? tal
1ff0: 29 0a 09 09 20 20 20 20 28 69 66 20 28 61 6e 64 )... (if (and
2000: 20 6c 69 6d 69 74 0a 09 09 09 20 20 20 20 20 28 limit.... (
2010: 3e 20 28 6c 65 6e 67 74 68 20 6e 65 77 2d 72 65 > (length new-re
2020: 73 29 20 6c 69 6d 69 74 29 29 0a 09 09 09 6e 65 s) limit))....ne
2030: 77 2d 72 65 73 20 3b 3b 20 28 74 61 6b 65 20 6e w-res ;; (take n
2040: 65 77 2d 72 65 73 20 6c 69 6d 69 74 29 20 20 3c ew-res limit) <
2050: 3d 20 6e 65 65 64 20 69 6e 74 65 6c 6c 69 67 65 = need intellige
2060: 6e 74 20 73 6f 72 74 69 6e 67 20 62 65 66 6f 72 nt sorting befor
2070: 65 20 74 68 69 73 20 77 69 6c 6c 20 77 6f 72 6b e this will work
2080: 0a 09 09 09 6e 65 77 2d 72 65 73 29 0a 09 09 20 ....new-res)...
2090: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
20a0: 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 2d l)(cdr tal) new-
20b0: 72 65 73 29 29 29 29 29 29 29 29 29 0a 0a 28 64 res)))))))))..(d
20c0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 efine (server:ge
20d0: 74 2d 6e 75 6d 2d 61 6c 69 76 65 20 73 72 76 6c t-num-alive srvl
20e0: 73 74 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d st). (let ((num
20f0: 2d 61 6c 69 76 65 20 30 29 29 0a 20 20 20 20 28 -alive 0)). (
2100: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
2110: 61 6d 62 64 61 20 28 73 65 72 76 65 72 29 0a 20 ambda (server).
2120: 20 20 20 20 20 20 28 6d 61 74 63 68 2d 6c 65 74 (match-let
2130: 20 28 28 28 6d 6f 64 2d 74 69 6d 65 20 68 6f 73 (((mod-time hos
2140: 74 20 70 6f 72 74 20 73 74 61 72 74 2d 74 69 6d t port start-tim
2150: 65 20 70 69 64 29 0a 09 09 20 20 20 20 73 65 72 e pid)... ser
2160: 76 65 72 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 ver)).. (let* ((
2170: 75 70 74 69 6d 65 20 20 28 2d 20 28 63 75 72 72 uptime (- (curr
2180: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6d 6f 64 ent-seconds) mod
2190: 2d 74 69 6d 65 29 29 0a 09 09 28 72 75 6e 74 69 -time))...(runti
21a0: 6d 65 20 28 69 66 20 73 74 61 72 74 2d 74 69 6d me (if start-tim
21b0: 65 0a 09 09 09 20 20 20 20 20 28 2d 20 6d 6f 64 e.... (- mod
21c0: 2d 74 69 6d 65 20 73 74 61 72 74 2d 74 69 6d 65 -time start-time
21d0: 29 0a 09 09 09 20 20 20 20 20 30 29 29 29 0a 09 ).... 0)))..
21e0: 20 20 20 28 69 66 20 28 3c 20 75 70 74 69 6d 65 (if (< uptime
21f0: 20 35 29 28 73 65 74 21 20 6e 75 6d 2d 61 6c 69 5)(set! num-ali
2200: 76 65 20 28 2b 20 6e 75 6d 2d 61 6c 69 76 65 20 ve (+ num-alive
2210: 31 29 29 29 29 29 29 0a 20 20 20 20 20 73 72 76 1)))))). srv
2220: 6c 73 74 29 0a 20 20 20 20 6e 75 6d 2d 61 6c 69 lst). num-ali
2230: 76 65 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 ve))..;; given a
2240: 20 6c 69 73 74 20 6f 66 20 73 65 72 76 65 72 73 list of servers
2250: 20 67 65 74 20 61 20 6c 69 73 74 20 6f 66 20 76 get a list of v
2260: 61 6c 69 64 20 73 65 72 76 65 72 73 2c 20 69 2e alid servers, i.
2270: 65 2e 20 61 74 20 6c 65 61 73 74 0a 3b 3b 20 31 e. at least.;; 1
2280: 30 20 73 65 63 6f 6e 64 73 20 6f 6c 64 2c 20 68 0 seconds old, h
2290: 61 73 20 73 74 61 72 74 65 64 20 61 6e 64 20 69 as started and i
22a0: 73 20 6c 65 73 73 20 74 68 61 6e 20 31 20 68 6f s less than 1 ho
22b0: 75 72 20 6f 6c 64 20 61 6e 64 20 69 73 0a 3b 3b ur old and is.;;
22c0: 20 61 63 74 69 76 65 20 28 69 2e 65 2e 20 6d 6f active (i.e. mo
22d0: 64 2d 74 69 6d 65 20 3c 20 31 30 20 73 65 63 6f d-time < 10 seco
22e0: 6e 64 73 0a 3b 3b 0a 3b 3b 20 6d 6f 64 2d 74 69 nds.;;.;; mod-ti
22f0: 6d 65 20 68 6f 73 74 20 70 6f 72 74 20 73 74 61 me host port sta
2300: 72 74 2d 74 69 6d 65 20 70 69 64 0a 3b 3b 0a 3b rt-time pid.;;.;
2310: 3b 20 73 6f 72 74 20 62 79 20 73 74 61 72 74 2d ; sort by start-
2320: 74 69 6d 65 20 64 65 73 63 65 6e 64 69 6e 67 2e time descending.
2330: 20 49 2e 65 2e 20 67 65 74 20 74 68 65 20 6f 6c I.e. get the ol
2340: 64 65 73 74 20 66 69 72 73 74 2e 20 59 6f 75 6e dest first. Youn
2350: 67 20 73 65 72 76 65 72 73 20 77 69 6c 6c 20 74 g servers will t
2360: 68 75 73 20 64 72 6f 70 20 6f 66 66 0a 3b 3b 20 hus drop off.;;
2370: 61 6e 64 20 73 65 72 76 65 72 73 20 73 68 6f 75 and servers shou
2380: 6c 64 20 73 74 69 63 6b 20 61 72 6f 75 6e 64 20 ld stick around
2390: 66 6f 72 20 61 62 6f 75 74 20 74 77 6f 20 68 6f for about two ho
23a0: 75 72 73 20 6f 72 20 73 6f 2e 0a 3b 3b 0a 28 64 urs or so..;;.(d
23b0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 efine (server:ge
23c0: 74 2d 62 65 73 74 20 73 72 76 6c 73 74 29 0a 20 t-best srvlst).
23d0: 20 28 6c 65 74 2a 20 28 28 6e 75 6d 73 20 28 73 (let* ((nums (s
23e0: 65 72 76 65 72 3a 67 65 74 2d 6e 75 6d 2d 73 65 erver:get-num-se
23f0: 72 76 65 72 73 29 29 0a 09 20 28 6e 6f 77 20 20 rvers)).. (now
2400: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2410: 29 29 0a 09 20 28 73 6c 73 74 20 28 73 6f 72 74 )).. (slst (sort
2420: 0a 09 09 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ...(filter (lamb
2430: 64 61 20 28 72 65 63 29 0a 09 09 09 20 20 28 69 da (rec).... (i
2440: 66 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 72 65 f (and (list? re
2450: 63 29 0a 09 09 09 09 20 20 20 28 3e 20 28 6c 65 c)..... (> (le
2460: 6e 67 74 68 20 72 65 63 29 20 32 29 29 0a 09 09 ngth rec) 2))...
2470: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 . (let ((st
2480: 61 72 74 2d 74 69 6d 65 20 28 6c 69 73 74 2d 72 art-time (list-r
2490: 65 66 20 72 65 63 20 33 29 29 0a 09 09 09 09 20 ef rec 3)).....
24a0: 20 20 20 28 6d 6f 64 2d 74 69 6d 65 20 20 20 28 (mod-time (
24b0: 6c 69 73 74 2d 72 65 66 20 72 65 63 20 30 29 29 list-ref rec 0))
24c0: 29 0a 09 09 09 09 3b 3b 20 28 70 72 69 6e 74 20 ).....;; (print
24d0: 22 73 74 61 72 74 2d 74 69 6d 65 3a 20 22 20 73 "start-time: " s
24e0: 74 61 72 74 2d 74 69 6d 65 20 22 20 6d 6f 64 2d tart-time " mod-
24f0: 74 69 6d 65 3a 20 22 20 6d 6f 64 2d 74 69 6d 65 time: " mod-time
2500: 29 0a 09 09 09 09 28 61 6e 64 20 73 74 61 72 74 ).....(and start
2510: 2d 74 69 6d 65 20 6d 6f 64 2d 74 69 6d 65 0a 09 -time mod-time..
2520: 09 09 09 20 20 20 20 20 28 3e 20 28 2d 20 6e 6f ... (> (- no
2530: 77 20 73 74 61 72 74 2d 74 69 6d 65 29 20 30 29 w start-time) 0)
2540: 20 20 20 20 3b 3b 20 62 65 65 6e 20 72 75 6e 6e ;; been runn
2550: 69 6e 67 20 61 74 20 6c 65 61 73 74 20 30 20 73 ing at least 0 s
2560: 65 63 6f 6e 64 73 0a 09 09 09 09 20 20 20 20 20 econds.....
2570: 28 3c 20 28 2d 20 6e 6f 77 20 6d 6f 64 2d 74 69 (< (- now mod-ti
2580: 6d 65 29 20 20 20 31 36 29 20 20 20 3b 3b 20 73 me) 16) ;; s
2590: 74 69 6c 6c 20 61 6c 69 76 65 20 2d 20 66 69 6c till alive - fil
25a0: 65 20 74 6f 75 63 68 65 64 20 69 6e 20 6c 61 73 e touched in las
25b0: 74 20 31 36 20 73 65 63 6f 6e 64 73 0a 09 09 09 t 16 seconds....
25c0: 09 20 20 20 20 20 28 3c 20 28 2d 20 6e 6f 77 20 . (< (- now
25d0: 73 74 61 72 74 2d 74 69 6d 65 29 20 0a 09 09 09 start-time) ....
25e0: 09 09 28 2b 20 28 2d 20 28 73 74 72 69 6e 67 2d ..(+ (- (string-
25f0: 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e >number (or (con
2600: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
2610: 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 figdat* "server"
2620: 20 22 72 75 6e 74 69 6d 65 22 29 20 22 33 36 30 "runtime") "360
2630: 30 22 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 0"))......
2640: 31 38 30 29 0a 09 09 09 09 09 20 20 20 28 72 61 180)...... (ra
2650: 6e 64 6f 6d 20 33 36 30 29 29 29 20 3b 3b 20 75 ndom 360))) ;; u
2660: 6e 64 65 72 20 6f 6e 65 20 68 6f 75 72 20 72 75 nder one hour ru
2670: 6e 6e 69 6e 67 20 74 69 6d 65 20 2b 2f 2d 20 31 nning time +/- 1
2680: 38 30 0a 09 09 09 09 20 20 20 20 20 29 29 0a 09 80..... ))..
2690: 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 09 09 .. #f))....
26a0: 73 72 76 6c 73 74 29 0a 09 09 28 6c 61 6d 62 64 srvlst)...(lambd
26b0: 61 20 28 61 20 62 29 0a 09 09 20 20 28 3c 20 28 a (a b)... (< (
26c0: 6c 69 73 74 2d 72 65 66 20 61 20 33 29 0a 09 09 list-ref a 3)...
26d0: 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 62 (list-ref b
26e0: 20 33 29 29 29 29 29 29 0a 20 20 20 20 28 69 66 3)))))). (if
26f0: 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 6c 73 74 (> (length slst
2700: 29 20 6e 75 6d 73 29 0a 09 28 74 61 6b 65 20 73 ) nums)..(take s
2710: 6c 73 74 20 6e 75 6d 73 29 0a 09 73 6c 73 74 29 lst nums)..slst)
2720: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 ))..(define (ser
2730: 76 65 72 3a 67 65 74 2d 66 69 72 73 74 2d 62 65 ver:get-first-be
2740: 73 74 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 st areapath). (
2750: 6c 65 74 20 28 28 73 72 76 72 73 20 28 73 65 72 let ((srvrs (ser
2760: 76 65 72 3a 67 65 74 2d 62 65 73 74 20 28 73 65 ver:get-best (se
2770: 72 76 65 72 3a 67 65 74 2d 6c 69 73 74 20 61 72 rver:get-list ar
2780: 65 61 70 61 74 68 29 29 29 29 0a 20 20 20 20 28 eapath)))). (
2790: 69 66 20 28 61 6e 64 20 73 72 76 72 73 0a 09 20 if (and srvrs..
27a0: 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (not (null?
27b0: 73 72 76 72 73 29 29 29 0a 09 28 63 61 72 20 73 srvrs)))..(car s
27c0: 72 76 72 73 29 0a 09 23 66 29 29 29 0a 0a 28 64 rvrs)..#f)))..(d
27d0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 efine (server:ge
27e0: 74 2d 72 61 6e 64 2d 62 65 73 74 20 61 72 65 61 t-rand-best area
27f0: 70 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 73 path). (let ((s
2800: 72 76 72 73 20 28 73 65 72 76 65 72 3a 67 65 74 rvrs (server:get
2810: 2d 62 65 73 74 20 28 73 65 72 76 65 72 3a 67 65 -best (server:ge
2820: 74 2d 6c 69 73 74 20 61 72 65 61 70 61 74 68 29 t-list areapath)
2830: 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ))). (if (and
2840: 20 28 6c 69 73 74 3f 20 73 72 76 72 73 29 0a 09 (list? srvrs)..
2850: 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (not (null?
2860: 20 73 72 76 72 73 29 29 29 0a 09 28 6c 65 74 2a srvrs)))..(let*
2870: 20 28 28 6c 65 6e 20 28 6c 65 6e 67 74 68 20 73 ((len (length s
2880: 72 76 72 73 29 29 0a 09 20 20 20 20 20 20 20 28 rvrs)).. (
2890: 69 64 78 20 28 72 61 6e 64 6f 6d 20 6c 65 6e 29 idx (random len)
28a0: 29 29 0a 09 20 20 28 6c 69 73 74 2d 72 65 66 20 )).. (list-ref
28b0: 73 72 76 72 73 20 69 64 78 29 29 0a 09 23 66 29 srvrs idx))..#f)
28c0: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 ))...(define (se
28d0: 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e 75 72 6c rver:record->url
28e0: 20 73 65 72 76 72 29 0a 20 20 28 6d 61 74 63 68 servr). (match
28f0: 2d 6c 65 74 20 28 28 28 6d 6f 64 2d 74 69 6d 65 -let (((mod-time
2900: 20 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 host port start
2910: 2d 74 69 6d 65 20 70 69 64 29 0a 09 20 20 20 20 -time pid)..
2920: 20 20 20 73 65 72 76 72 29 29 0a 20 20 20 20 28 servr)). (
2930: 69 66 20 28 61 6e 64 20 68 6f 73 74 20 70 6f 72 if (and host por
2940: 74 29 0a 09 28 63 6f 6e 63 20 68 6f 73 74 20 22 t)..(conc host "
2950: 3a 22 20 70 6f 72 74 29 0a 09 23 66 29 29 29 0a :" port)..#f))).
2960: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
2970: 3a 67 65 74 2d 63 6c 69 65 6e 74 2d 73 69 67 6e :get-client-sign
2980: 61 74 75 72 65 29 20 3b 3b 20 42 42 3e 20 77 68 ature) ;; BB> wh
2990: 79 20 69 73 20 74 68 69 73 20 70 72 6f 63 20 6e y is this proc n
29a0: 61 6d 65 64 20 22 67 65 74 2d 22 3f 20 20 69 74 amed "get-"? it
29b0: 20 72 65 74 75 72 6e 73 20 6e 6f 74 68 69 6e 67 returns nothing
29c0: 20 2d 2d 20 73 65 74 21 20 68 61 73 20 6e 6f 74 -- set! has not
29d0: 20 72 65 74 75 72 6e 20 76 61 6c 75 65 2e 0a 20 return value..
29e0: 20 28 69 66 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d (if *my-client-
29f0: 73 69 67 6e 61 74 75 72 65 2a 20 2a 6d 79 2d 63 signature* *my-c
2a00: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature*
2a10: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 69 . (let ((si
2a20: 67 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 g (server:mk-sig
2a30: 6e 61 74 75 72 65 29 29 29 0a 20 20 20 20 20 20 nature))).
2a40: 20 20 28 73 65 74 21 20 2a 6d 79 2d 63 6c 69 65 (set! *my-clie
2a50: 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 73 69 nt-signature* si
2a60: 67 29 0a 20 20 20 20 20 20 20 20 2a 6d 79 2d 63 g). *my-c
2a70: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature*
2a80: 29 29 29 0a 0a 3b 3b 20 6b 69 6e 64 20 73 74 61 )))..;; kind sta
2a90: 72 74 20 75 70 20 6f 66 20 73 65 72 76 65 72 73 rt up of servers
2aa0: 2c 20 77 61 69 74 20 34 30 20 73 65 63 6f 6e 64 , wait 40 second
2ab0: 73 20 62 65 66 6f 72 65 20 61 6c 6c 6f 77 69 6e s before allowin
2ac0: 67 20 61 6e 6f 74 68 65 72 20 73 65 72 76 65 72 g another server
2ad0: 20 66 6f 72 20 61 20 67 69 76 65 6e 0a 3b 3b 20 for a given.;;
2ae0: 72 75 6e 2d 69 64 20 74 6f 20 62 65 20 6c 61 75 run-id to be lau
2af0: 6e 63 68 65 64 0a 28 64 65 66 69 6e 65 20 28 73 nched.(define (s
2b00: 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 61 erver:kind-run a
2b10: 72 65 61 70 61 74 68 29 0a 20 20 28 69 66 20 28 reapath). (if (
2b20: 6e 6f 74 20 28 73 65 72 76 65 72 3a 63 68 65 63 not (server:chec
2b30: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 k-if-running are
2b40: 61 70 61 74 68 29 29 20 3b 3b 20 77 68 79 20 74 apath)) ;; why t
2b50: 72 79 20 69 66 20 74 68 65 72 65 20 69 73 20 61 ry if there is a
2b60: 6c 72 65 61 64 79 20 61 20 73 65 72 76 65 72 20 lready a server
2b70: 72 75 6e 6e 69 6e 67 3f 0a 20 20 20 20 20 20 28 running?. (
2b80: 6c 65 74 2a 20 28 28 6c 61 73 74 2d 72 75 6e 2d let* ((last-run-
2b90: 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d dat (hash-table-
2ba0: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 72 ref/default *ser
2bb0: 76 65 72 2d 6b 69 6e 64 2d 72 75 6e 2a 20 61 72 ver-kind-run* ar
2bc0: 65 61 70 61 74 68 20 27 28 30 20 30 29 29 29 20 eapath '(0 0)))
2bd0: 3b 3b 20 63 61 6c 6c 6e 75 6d 2c 20 77 68 65 6e ;; callnum, when
2be0: 72 75 6e 0a 09 20 20 20 20 20 28 63 61 6c 6c 2d run.. (call-
2bf0: 6e 75 6d 20 20 20 20 20 28 63 61 72 20 6c 61 73 num (car las
2c00: 74 2d 72 75 6e 2d 64 61 74 29 29 0a 09 20 20 20 t-run-dat))..
2c10: 20 20 28 77 68 65 6e 2d 72 75 6e 20 20 20 20 20 (when-run
2c20: 28 63 61 64 72 20 6c 61 73 74 2d 72 75 6e 2d 64 (cadr last-run-d
2c30: 61 74 29 29 0a 09 20 20 20 20 20 28 72 75 6e 2d at)).. (run-
2c40: 64 65 6c 61 79 20 20 20 20 28 2b 20 28 63 61 73 delay (+ (cas
2c50: 65 20 63 61 6c 6c 2d 6e 75 6d 0a 09 09 09 09 28 e call-num.....(
2c60: 28 30 29 20 20 20 20 30 29 0a 09 09 09 09 28 28 (0) 0).....((
2c70: 31 29 20 20 20 32 30 29 0a 09 09 09 09 28 28 32 1) 20).....((2
2c80: 29 20 20 33 30 30 29 0a 09 09 09 09 28 65 6c 73 ) 300).....(els
2c90: 65 20 36 30 30 29 29 0a 09 09 09 20 20 20 20 20 e 600))....
2ca0: 20 28 72 61 6e 64 6f 6d 20 35 29 29 29 20 20 20 (random 5)))
2cb0: 3b 3b 20 61 64 64 20 61 20 73 6d 61 6c 6c 20 72 ;; add a small r
2cc0: 61 6e 64 6f 6d 20 6e 75 6d 62 65 72 20 6a 75 73 andom number jus
2cd0: 74 20 69 6e 20 63 61 73 65 20 61 20 6c 6f 74 20 t in case a lot
2ce0: 6f 66 20 6a 6f 62 73 20 68 69 74 20 74 68 65 20 of jobs hit the
2cf0: 77 6f 72 6b 20 68 6f 73 74 73 20 73 69 6d 75 6c work hosts simul
2d00: 74 61 6e 65 6f 75 73 6c 79 0a 09 20 20 20 20 20 taneously..
2d10: 28 6c 6f 63 6b 2d 66 69 6c 65 20 20 20 20 28 63 (lock-file (c
2d20: 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f 6c onc areapath "/l
2d30: 6f 67 73 2f 73 65 72 76 65 72 2d 73 74 61 72 74 ogs/server-start
2d40: 2e 6c 6f 63 6b 22 29 29 29 0a 09 28 69 66 09 28 .lock")))..(if.(
2d50: 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 > (- (current-se
2d60: 63 6f 6e 64 73 29 20 77 68 65 6e 2d 72 75 6e 29 conds) when-run)
2d70: 20 72 75 6e 2d 64 65 6c 61 79 29 0a 09 09 28 62 run-delay)...(b
2d80: 65 67 69 6e 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e egin... (common
2d90: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 :simple-file-loc
2da0: 6b 2d 61 6e 64 2d 77 61 69 74 20 6c 6f 63 6b 2d k-and-wait lock-
2db0: 66 69 6c 65 20 65 78 70 69 72 65 2d 74 69 6d 65 file expire-time
2dc0: 3a 20 31 35 29 0a 09 09 20 20 28 73 65 72 76 65 : 15)... (serve
2dd0: 72 3a 72 75 6e 20 61 72 65 61 70 61 74 68 29 0a r:run areapath).
2de0: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
2df0: 70 21 20 35 29 20 3b 3b 20 64 6f 6e 27 74 20 72 p! 5) ;; don't r
2e00: 65 6c 65 61 73 65 20 74 68 65 20 6c 6f 63 6b 20 elease the lock
2e10: 66 6f 72 20 61 74 20 6c 65 61 73 74 20 61 20 66 for at least a f
2e20: 65 77 20 73 65 63 6f 6e 64 73 0a 09 09 20 20 28 ew seconds... (
2e30: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
2e40: 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 le-release-lock
2e50: 6c 6f 63 6b 2d 66 69 6c 65 29 29 29 0a 09 28 68 lock-file)))..(h
2e60: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
2e70: 73 65 72 76 65 72 2d 6b 69 6e 64 2d 72 75 6e 2a server-kind-run*
2e80: 20 61 72 65 61 70 61 74 68 20 28 6c 69 73 74 20 areapath (list
2e90: 28 2b 20 63 61 6c 6c 2d 6e 75 6d 20 31 29 28 63 (+ call-num 1)(c
2ea0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
2eb0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
2ec0: 65 72 76 65 72 3a 73 74 61 72 74 2d 61 6e 64 2d erver:start-and-
2ed0: 77 61 69 74 20 61 72 65 61 70 61 74 68 20 23 21 wait areapath #!
2ee0: 6b 65 79 20 28 74 69 6d 65 6f 75 74 20 36 30 29 key (timeout 60)
2ef0: 29 0a 20 20 28 6c 65 74 20 28 28 67 69 76 65 2d ). (let ((give-
2f00: 75 70 2d 74 69 6d 65 20 28 2b 20 28 63 75 72 72 up-time (+ (curr
2f10: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 74 69 6d ent-seconds) tim
2f20: 65 6f 75 74 29 29 29 0a 20 20 20 20 28 6c 65 74 eout))). (let
2f30: 20 6c 6f 6f 70 20 28 28 73 65 72 76 65 72 2d 75 loop ((server-u
2f40: 72 6c 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b rl (server:check
2f50: 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 65 61 -if-running area
2f60: 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 20 28 path)).. (
2f70: 74 72 79 2d 6e 75 6d 20 20 20 20 30 29 29 0a 20 try-num 0)).
2f80: 20 20 20 20 20 28 69 66 20 28 6f 72 20 73 65 72 (if (or ser
2f90: 76 65 72 2d 75 72 6c 0a 09 20 20 20 20 20 20 28 ver-url.. (
2fa0: 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e > (current-secon
2fb0: 64 73 29 20 67 69 76 65 2d 75 70 2d 74 69 6d 65 ds) give-up-time
2fc0: 29 29 20 3b 3b 20 73 65 72 76 65 72 2d 75 72 6c )) ;; server-url
2fd0: 20 77 69 6c 6c 20 62 65 20 23 66 20 69 66 20 6e will be #f if n
2fe0: 6f 20 73 65 72 76 65 72 20 61 76 61 69 6c 61 62 o server availab
2ff0: 6c 65 2e 0a 09 20 20 73 65 72 76 65 72 2d 75 72 le... server-ur
3000: 6c 0a 09 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d l.. (let ((num-
3010: 6f 6b 20 28 6c 65 6e 67 74 68 20 28 73 65 72 76 ok (length (serv
3020: 65 72 3a 67 65 74 2d 62 65 73 74 20 28 73 65 72 er:get-best (ser
3030: 76 65 72 3a 67 65 74 2d 6c 69 73 74 20 61 72 65 ver:get-list are
3040: 61 70 61 74 68 29 29 29 29 29 0a 09 20 20 20 20 apath)))))..
3050: 28 69 66 20 28 61 6e 64 20 28 3e 20 74 72 79 2d (if (and (> try-
3060: 6e 75 6d 20 30 29 20 20 3b 3b 20 66 69 72 73 74 num 0) ;; first
3070: 20 74 69 6d 65 20 74 68 72 6f 75 67 68 20 73 69 time through si
3080: 6d 70 6c 79 20 77 61 69 74 20 61 20 6c 69 74 74 mply wait a litt
3090: 6c 65 20 77 68 69 6c 65 20 74 68 65 6e 20 74 72 le while then tr
30a0: 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 28 y again... (
30b0: 3c 20 6e 75 6d 2d 6f 6b 20 31 29 29 20 20 3b 3b < num-ok 1)) ;;
30c0: 20 69 66 20 74 68 65 72 65 20 61 72 65 20 6e 6f if there are no
30d0: 20 64 65 63 65 6e 74 20 63 61 6e 64 69 64 61 74 decent candidat
30e0: 65 73 20 66 6f 72 20 73 65 72 76 65 72 73 20 74 es for servers t
30f0: 68 65 6e 20 74 72 79 20 73 74 61 72 74 69 6e 67 hen try starting
3100: 20 61 20 6e 65 77 20 6f 6e 65 0a 09 09 28 73 65 a new one...(se
3110: 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 61 72 rver:kind-run ar
3120: 65 61 70 61 74 68 29 29 0a 09 20 20 20 20 28 74 eapath)).. (t
3130: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a hread-sleep! 5).
3140: 09 20 20 20 20 28 6c 6f 6f 70 20 28 73 65 72 76 . (loop (serv
3150: 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e er:check-if-runn
3160: 69 6e 67 20 61 72 65 61 70 61 74 68 29 0a 09 09 ing areapath)...
3170: 20 20 28 2b 20 74 72 79 2d 6e 75 6d 20 31 29 29 (+ try-num 1))
3180: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 )))))..(define s
3190: 65 72 76 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e erver:try-runnin
31a0: 67 20 73 65 72 76 65 72 3a 72 75 6e 29 20 3b 3b g server:run) ;;
31b0: 20 74 68 65 72 65 20 69 73 20 6e 6f 20 6d 6f 72 there is no mor
31c0: 65 20 70 65 72 2d 72 75 6e 20 73 65 72 76 65 72 e per-run server
31d0: 73 20 3b 3b 20 52 45 4d 4f 56 45 20 4d 45 2e 20 s ;; REMOVE ME.
31e0: 42 55 47 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 BUG...(define (s
31f0: 65 72 76 65 72 3a 67 65 74 2d 6e 75 6d 2d 73 65 erver:get-num-se
3200: 72 76 65 72 73 20 23 21 6b 65 79 20 28 6e 75 6d rvers #!key (num
3210: 73 65 72 76 65 72 73 20 32 29 29 0a 20 20 28 6c servers 2)). (l
3220: 65 74 20 28 28 6e 73 20 28 73 74 72 69 6e 67 2d et ((ns (string-
3230: 3e 6e 75 6d 62 65 72 0a 09 20 20 20 20 20 28 6f >number.. (o
3240: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
3250: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
3260: 65 72 76 65 72 22 20 22 6e 75 6d 73 65 72 76 65 erver" "numserve
3270: 72 73 22 29 20 22 6e 6f 74 61 6e 75 6d 62 65 72 rs") "notanumber
3280: 22 29 29 29 29 0a 20 20 20 20 28 6f 72 20 6e 73 ")))). (or ns
3290: 20 6e 75 6d 73 65 72 76 65 72 73 29 29 29 0a 0a numservers)))..
32a0: 3b 3b 20 6e 6f 20 6c 6f 6e 67 65 72 20 63 61 72 ;; no longer car
32b0: 65 20 69 66 20 6d 75 6c 74 69 70 6c 65 20 73 65 e if multiple se
32c0: 72 76 65 72 73 20 61 72 65 20 73 74 61 72 74 65 rvers are starte
32d0: 64 20 62 79 20 61 63 63 69 64 65 6e 74 2e 20 6f d by accident. o
32e0: 6c 64 65 72 20 73 65 72 76 65 72 73 20 77 69 6c lder servers wil
32f0: 6c 20 64 72 6f 70 20 6f 66 66 20 69 6e 20 74 69 l drop off in ti
3300: 6d 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 me..;;.(define (
3310: 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d server:check-if-
3320: 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 61 74 68 running areapath
3330: 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 6e 75 6d ) ;; #!key (num
3340: 73 65 72 76 65 72 73 20 22 32 22 29 29 0a 20 20 servers "2")).
3350: 28 6c 65 74 2a 20 28 28 6e 73 20 20 20 20 20 20 (let* ((ns
3360: 20 20 20 20 20 20 28 73 65 72 76 65 72 3a 67 65 (server:ge
3370: 74 2d 6e 75 6d 2d 73 65 72 76 65 72 73 29 29 0a t-num-servers)).
3380: 09 20 28 73 65 72 76 65 72 73 20 20 20 20 20 20 . (servers
3390: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 (server:get-bes
33a0: 74 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6c 69 t (server:get-li
33b0: 73 74 20 61 72 65 61 70 61 74 68 29 29 29 29 0a st areapath)))).
33c0: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 73 ;; (print "s
33d0: 65 72 76 65 72 73 3a 20 22 20 73 65 72 76 65 72 ervers: " server
33e0: 73 20 22 20 6e 73 3a 20 22 20 6e 73 29 0a 20 20 s " ns: " ns).
33f0: 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 73 (if (or (and s
3400: 65 72 76 65 72 73 0a 09 09 20 28 6e 75 6c 6c 3f ervers... (null?
3410: 20 73 65 72 76 65 72 73 29 29 0a 09 20 20 20 20 servers))..
3420: 28 6e 6f 74 20 73 65 72 76 65 72 73 29 0a 09 20 (not servers)..
3430: 20 20 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 73 (and (list? s
3440: 65 72 76 65 72 73 29 0a 09 09 20 28 3c 20 28 6c ervers)... (< (l
3450: 65 6e 67 74 68 20 73 65 72 76 65 72 73 29 20 28 ength servers) (
3460: 72 61 6e 64 6f 6d 20 6e 73 29 29 29 29 20 3b 3b random ns)))) ;;
3470: 20 73 6f 6d 65 77 68 65 72 65 20 62 65 74 77 65 somewhere betwe
3480: 65 6e 20 30 20 61 6e 64 20 6e 75 6d 73 65 72 76 en 0 and numserv
3490: 65 72 73 0a 20 20 20 20 20 20 20 20 23 66 0a 20 ers. #f.
34a0: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 (let loop
34b0: 20 28 28 68 65 64 20 28 63 61 72 20 73 65 72 76 ((hed (car serv
34c0: 65 72 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ers)).
34d0: 20 20 20 20 20 20 20 20 20 28 74 61 6c 20 28 63 (tal (c
34e0: 64 72 20 73 65 72 76 65 72 73 29 29 29 0a 20 20 dr servers))).
34f0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 (let ((r
3500: 65 73 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b es (server:check
3510: 2d 73 65 72 76 65 72 20 68 65 64 29 29 29 0a 20 -server hed))).
3520: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 72 (if r
3530: 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 es.
3540: 20 20 20 72 65 73 0a 20 20 20 20 20 20 20 20 20 res.
3550: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null
3560: 3f 20 74 61 6c 29 0a 20 20 20 20 20 20 20 20 20 ? tal).
3570: 20 20 20 20 20 20 20 20 20 20 20 23 66 0a 20 20 #f.
3580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3590: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
35a0: 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 )(cdr tal)))))))
35b0: 29 29 0a 0a 3b 3b 20 70 69 6e 67 20 74 68 65 20 ))..;; ping the
35c0: 67 69 76 65 6e 20 73 65 72 76 65 72 0a 3b 3b 0a given server.;;.
35d0: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
35e0: 63 68 65 63 6b 2d 73 65 72 76 65 72 20 73 65 72 check-server ser
35f0: 76 65 72 2d 72 65 63 6f 72 64 29 0a 20 20 28 6c ver-record). (l
3600: 65 74 2a 20 28 28 73 65 72 76 65 72 2d 75 72 6c et* ((server-url
3610: 20 28 73 65 72 76 65 72 3a 72 65 63 6f 72 64 2d (server:record-
3620: 3e 75 72 6c 20 73 65 72 76 65 72 2d 72 65 63 6f >url server-reco
3630: 72 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 rd)). (r
3640: 65 73 20 20 20 20 20 20 20 20 28 63 61 73 65 20 es (case
3650: 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a *transport-type*
3660: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3670: 20 20 20 20 20 20 20 20 28 28 68 74 74 70 29 28 ((http)(
3680: 73 65 72 76 65 72 3a 70 69 6e 67 20 73 65 72 76 server:ping serv
3690: 65 72 2d 75 72 6c 29 29 0a 20 20 20 20 20 20 20 er-url)).
36a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36b0: 3b 3b 20 28 28 6e 6d 73 67 29 28 6e 6d 73 67 2d ;; ((nmsg)(nmsg-
36c0: 74 72 61 6e 73 70 6f 72 74 3a 70 69 6e 67 20 28 transport:ping (
36d0: 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 tasks:hostinfo-g
36e0: 65 74 2d 69 6e 74 65 72 66 61 63 65 20 73 65 72 et-interface ser
36f0: 76 65 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 ver).
3700: 20 20 20 20 20 20 20 20 20 20 20 20 29 29 29 0a ))).
3710: 20 20 20 20 28 69 66 20 72 65 73 0a 20 20 20 20 (if res.
3720: 20 20 20 20 73 65 72 76 65 72 2d 75 72 6c 0a 09 server-url..
3730: 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f)))..(define (
3740: 73 65 72 76 65 72 3a 6b 69 6c 6c 20 73 65 72 76 server:kill serv
3750: 72 29 0a 20 20 28 6d 61 74 63 68 2d 6c 65 74 20 r). (match-let
3760: 28 28 28 6d 6f 64 2d 74 69 6d 65 20 68 6f 73 74 (((mod-time host
3770: 6e 61 6d 65 20 70 6f 72 74 20 73 74 61 72 74 2d name port start-
3780: 74 69 6d 65 20 70 69 64 29 0a 09 20 20 20 20 20 time pid)..
3790: 20 20 73 65 72 76 72 29 29 0a 20 20 20 20 28 74 servr)). (t
37a0: 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 asks:kill-server
37b0: 20 68 6f 73 74 6e 61 6d 65 20 70 69 64 29 29 29 hostname pid)))
37c0: 0a 0a 3b 3b 20 63 61 6c 6c 65 64 20 69 6e 20 6d ..;; called in m
37d0: 65 67 61 74 65 73 74 2e 73 63 6d 2c 20 68 6f 73 egatest.scm, hos
37e0: 74 2d 70 6f 72 74 20 69 73 20 73 74 72 69 6e 67 t-port is string
37f0: 20 68 6f 73 74 6e 61 6d 65 3a 70 6f 72 74 0a 3b hostname:port.;
3800: 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 ;.;; NOTE: This
3810: 69 73 20 4e 4f 54 20 63 61 6c 6c 65 64 20 64 69 is NOT called di
3820: 72 65 63 74 6c 79 20 66 72 6f 6d 20 63 6c 69 65 rectly from clie
3830: 6e 74 73 20 61 73 20 6e 6f 74 20 61 6c 6c 20 74 nts as not all t
3840: 72 61 6e 73 70 6f 72 74 73 20 73 75 70 70 6f 72 ransports suppor
3850: 74 20 61 20 63 6c 69 65 6e 74 20 72 75 6e 6e 69 t a client runni
3860: 6e 67 0a 3b 3b 20 20 20 20 20 20 20 69 6e 20 74 ng.;; in t
3870: 68 65 20 73 61 6d 65 20 70 72 6f 63 65 73 73 20 he same process
3880: 61 73 20 74 68 65 20 73 65 72 76 65 72 2e 0a 3b as the server..;
3890: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 ;.(define (serve
38a0: 72 3a 70 69 6e 67 20 68 6f 73 74 2d 70 6f 72 74 r:ping host-port
38b0: 2d 69 6e 20 23 21 6b 65 79 20 28 64 6f 2d 65 78 -in #!key (do-ex
38c0: 69 74 20 23 66 29 29 0a 20 20 28 6c 65 74 20 28 it #f)). (let (
38d0: 28 68 6f 73 74 3a 70 6f 72 74 20 28 69 66 20 28 (host:port (if (
38e0: 6e 6f 74 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e not host-port-in
38f0: 29 20 3b 3b 20 75 73 65 20 72 65 61 64 2d 64 6f ) ;; use read-do
3900: 74 73 65 72 76 65 72 20 74 6f 20 66 69 6e 64 0a tserver to find.
3910: 09 09 20 20 20 20 20 20 20 23 66 20 3b 3b 20 28 .. #f ;; (
3920: 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d server:check-if-
3930: 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 running *toppath
3940: 2a 29 0a 09 09 3b 3b 20 28 69 66 20 28 6e 75 6d *)...;; (if (num
3950: 62 65 72 3f 20 68 6f 73 74 2d 70 6f 72 74 2d 69 ber? host-port-i
3960: 6e 29 20 3b 3b 20 77 65 20 77 65 72 65 20 68 61 n) ;; we were ha
3970: 6e 64 65 64 20 61 20 73 65 72 76 65 72 2d 69 64 nded a server-id
3980: 0a 09 09 3b 3b 20 09 20 20 20 28 6c 65 74 20 28 ...;; . (let (
3990: 28 73 72 65 63 20 28 74 61 73 6b 73 3a 67 65 74 (srec (tasks:get
39a0: 2d 73 65 72 76 65 72 2d 62 79 2d 69 64 20 28 64 -server-by-id (d
39b0: 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 b:delay-if-busy
39c0: 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 (tasks:open-db))
39d0: 20 68 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 29 29 host-port-in)))
39e0: 0a 09 09 3b 3b 20 09 20 20 20 20 20 3b 3b 20 28 ...;; . ;; (
39f0: 70 72 69 6e 74 20 22 73 72 65 63 3a 20 22 20 73 print "srec: " s
3a00: 72 65 63 20 22 20 68 6f 73 74 2d 70 6f 72 74 2d rec " host-port-
3a10: 69 6e 3a 20 22 20 68 6f 73 74 2d 70 6f 72 74 2d in: " host-port-
3a20: 69 6e 29 0a 09 09 3b 3b 20 09 20 20 20 20 20 28 in)...;; . (
3a30: 69 66 20 73 72 65 63 0a 09 09 3b 3b 20 09 09 20 if srec...;; ..
3a40: 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 (conc (vector-re
3a50: 66 20 73 72 65 63 20 33 29 20 22 3a 22 20 28 76 f srec 3) ":" (v
3a60: 65 63 74 6f 72 2d 72 65 66 20 73 72 65 63 20 34 ector-ref srec 4
3a70: 29 29 0a 09 09 3b 3b 20 09 09 20 28 63 6f 6e 63 ))...;; .. (conc
3a80: 20 22 6e 6f 20 73 75 63 68 20 73 65 72 76 65 72 "no such server
3a90: 2d 69 64 20 22 20 68 6f 73 74 2d 70 6f 72 74 2d -id " host-port-
3aa0: 69 6e 29 29 29 0a 09 09 20 20 20 20 20 20 20 68 in)))... h
3ab0: 6f 73 74 2d 70 6f 72 74 2d 69 6e 29 29 29 20 3b ost-port-in))) ;
3ac0: 3b 20 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 ; ). (let* ((
3ad0: 68 6f 73 74 2d 70 6f 72 74 20 28 69 66 20 68 6f host-port (if ho
3ae0: 73 74 3a 70 6f 72 74 0a 09 09 09 20 20 28 6c 65 st:port.... (le
3af0: 74 20 28 28 73 6c 73 74 20 28 73 74 72 69 6e 67 t ((slst (string
3b00: 2d 73 70 6c 69 74 20 20 20 68 6f 73 74 3a 70 6f -split host:po
3b10: 72 74 20 22 3a 22 29 29 29 0a 09 09 09 20 20 20 rt ":")))....
3b20: 20 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 (if (eq? (lengt
3b30: 68 20 73 6c 73 74 29 20 32 29 0a 09 09 09 09 28 h slst) 2).....(
3b40: 6c 69 73 74 20 28 63 61 72 20 73 6c 73 74 29 28 list (car slst)(
3b50: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
3b60: 63 61 64 72 20 73 6c 73 74 29 29 29 0a 09 09 09 cadr slst)))....
3b70: 09 23 66 29 29 0a 09 09 09 20 20 23 66 29 29 29 .#f)).... #f)))
3b80: 0a 3b 3b 09 20 20 20 28 74 6f 70 70 61 74 68 20 .;;. (toppath
3b90: 20 20 20 20 20 20 28 6c 61 75 6e 63 68 3a 73 65 (launch:se
3ba0: 74 75 70 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 tup))). ;;
3bb0: 28 70 72 69 6e 74 20 22 68 6f 73 74 2d 70 6f 72 (print "host-por
3bc0: 74 3d 22 20 68 6f 73 74 2d 70 6f 72 74 29 0a 20 t=" host-port).
3bd0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 68 6f (if (not ho
3be0: 73 74 2d 70 6f 72 74 29 0a 09 20 20 28 62 65 67 st-port).. (beg
3bf0: 69 6e 0a 09 20 20 20 20 28 69 66 20 68 6f 73 74 in.. (if host
3c00: 2d 70 6f 72 74 2d 69 6e 0a 09 09 28 64 65 62 75 -port-in...(debu
3c10: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3c20: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 45 lt-log-port* "E
3c30: 52 52 4f 52 3a 20 62 61 64 20 68 6f 73 74 3a 70 RROR: bad host:p
3c40: 6f 72 74 22 29 29 0a 09 20 20 20 20 28 69 66 20 ort")).. (if
3c50: 64 6f 2d 65 78 69 74 20 28 65 78 69 74 20 31 29 do-exit (exit 1)
3c60: 29 0a 09 20 20 20 20 23 66 29 0a 09 20 20 28 6c ).. #f).. (l
3c70: 65 74 2a 20 28 28 69 66 61 63 65 20 20 20 20 20 et* ((iface
3c80: 20 28 63 61 72 20 68 6f 73 74 2d 70 6f 72 74 29 (car host-port)
3c90: 29 0a 09 09 20 28 70 6f 72 74 20 20 20 20 20 20 )... (port
3ca0: 20 28 63 61 64 72 20 68 6f 73 74 2d 70 6f 72 74 (cadr host-port
3cb0: 29 29 0a 09 09 20 28 73 65 72 76 65 72 2d 64 61 ))... (server-da
3cc0: 74 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 t (http-transpor
3cd0: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
3ce0: 20 69 66 61 63 65 20 70 6f 72 74 29 29 0a 09 09 iface port))...
3cf0: 20 28 6c 6f 67 69 6e 2d 72 65 73 20 20 28 72 6d (login-res (rm
3d00: 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d t:login-no-auto-
3d10: 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 73 65 72 client-setup ser
3d20: 76 65 72 2d 64 61 74 29 29 29 0a 09 20 20 20 20 ver-dat)))..
3d30: 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 (if (and (list?
3d40: 6c 6f 67 69 6e 2d 72 65 73 29 0a 09 09 20 20 20 login-res)...
3d50: 20 20 28 63 61 72 20 6c 6f 67 69 6e 2d 72 65 73 (car login-res
3d60: 29 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 ))...(begin...
3d70: 3b 3b 20 28 70 72 69 6e 74 20 22 4c 4f 47 49 4e ;; (print "LOGIN
3d80: 5f 4f 4b 22 29 0a 09 09 20 20 28 69 66 20 64 6f _OK")... (if do
3d90: 2d 65 78 69 74 20 28 65 78 69 74 20 30 29 29 0a -exit (exit 0)).
3da0: 09 09 20 20 23 74 29 0a 09 09 28 62 65 67 69 6e .. #t)...(begin
3db0: 0a 09 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ... ;; (print "
3dc0: 4c 4f 47 49 4e 5f 46 41 49 4c 45 44 22 29 0a 09 LOGIN_FAILED")..
3dd0: 09 20 20 28 69 66 20 64 6f 2d 65 78 69 74 20 28 . (if do-exit (
3de0: 65 78 69 74 20 31 29 29 0a 09 09 20 20 23 66 29 exit 1))... #f)
3df0: 29 29 29 29 29 29 0a 0a 3b 3b 20 72 75 6e 20 70 ))))))..;; run p
3e00: 69 6e 67 20 69 6e 20 73 65 70 61 72 61 74 65 20 ing in separate
3e10: 70 72 6f 63 65 73 73 2c 20 73 61 66 65 73 74 20 process, safest
3e20: 77 61 79 20 69 6e 20 73 6f 6d 65 20 63 61 73 65 way in some case
3e30: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 s.;;.(define (se
3e40: 72 76 65 72 3a 70 69 6e 67 2d 73 65 72 76 65 72 rver:ping-server
3e50: 20 69 66 61 63 65 70 6f 72 74 29 0a 20 20 28 77 ifaceport). (w
3e60: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
3e70: 69 70 65 20 0a 20 20 20 28 63 6f 6e 63 20 28 63 ipe . (conc (c
3e80: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 ommon:get-megate
3e90: 73 74 2d 65 78 65 29 20 22 20 2d 70 69 6e 67 20 st-exe) " -ping
3ea0: 22 20 69 66 61 63 65 70 6f 72 74 29 0a 20 20 20 " ifaceport).
3eb0: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 (lambda ().
3ec0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 (let loop ((inl
3ed0: 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 09 09 28 (read-line))...(
3ee0: 72 65 73 20 22 4e 4f 52 45 50 4c 59 22 29 29 0a res "NOREPLY")).
3ef0: 20 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d (if (eof-
3f00: 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 20 20 object? inl)..
3f10: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
3f20: 73 79 6d 62 6f 6c 20 72 65 73 29 0a 09 20 20 20 symbol res)..
3f30: 20 20 28 28 4e 4f 52 45 50 4c 59 29 20 20 23 66 ((NOREPLY) #f
3f40: 29 0a 09 20 20 20 20 20 28 28 4c 4f 47 49 4e 5f ).. ((LOGIN_
3f50: 4f 4b 29 20 23 74 29 0a 09 20 20 20 20 20 28 65 OK) #t).. (e
3f60: 6c 73 65 20 20 20 20 20 20 20 23 66 29 29 0a 09 lse #f))..
3f70: 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c (loop (read-l
3f80: 69 6e 65 29 20 69 6e 6c 29 29 29 29 29 29 0a 0a ine) inl))))))..
3f90: 3b 3b 20 4e 4f 54 20 55 53 45 44 20 28 77 65 6c ;; NOT USED (wel
3fa0: 6c 2c 20 6f 6b 2c 20 72 65 66 65 72 65 6e 63 65 l, ok, reference
3fb0: 20 69 6e 20 72 70 63 2d 74 72 61 6e 73 70 6f 72 in rpc-transpor
3fc0: 74 20 62 75 74 20 6f 74 68 65 72 77 69 73 65 20 t but otherwise
3fd0: 6e 6f 74 20 75 73 65 64 29 2e 0a 3b 3b 0a 28 64 not used)..;;.(d
3fe0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6c 6f efine (server:lo
3ff0: 67 69 6e 20 74 6f 70 70 61 74 68 29 0a 20 20 28 gin toppath). (
4000: 6c 61 6d 62 64 61 20 28 74 6f 70 70 61 74 68 29 lambda (toppath)
4010: 0a 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6c . (set! *db-l
4020: 61 73 74 2d 61 63 63 65 73 73 2a 20 28 63 75 72 ast-access* (cur
4030: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b rent-seconds)) ;
4040: 3b 20 6d 69 67 68 74 20 6e 6f 74 20 62 65 20 6e ; might not be n
4050: 65 65 64 65 64 2e 0a 20 20 20 20 28 69 66 20 28 eeded.. (if (
4060: 65 71 75 61 6c 3f 20 2a 74 6f 70 70 61 74 68 2a equal? *toppath*
4070: 20 74 6f 70 70 61 74 68 29 0a 09 23 74 0a 09 23 toppath)..#t..#
4080: 66 29 29 29 0a 0a 3b 3b 20 74 69 6d 65 6f 75 74 f)))..;; timeout
4090: 20 69 73 20 68 6d 73 20 73 74 72 69 6e 67 3a 20 is hms string:
40a0: 31 68 20 35 6d 20 33 73 2c 20 64 65 66 61 75 6c 1h 5m 3s, defaul
40b0: 74 20 69 73 20 31 20 6d 69 6e 75 74 65 0a 3b 3b t is 1 minute.;;
40c0: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
40d0: 3a 65 78 70 69 72 61 74 69 6f 6e 2d 74 69 6d 65 :expiration-time
40e0: 6f 75 74 29 0a 20 20 28 6c 65 74 20 28 28 74 6d out). (let ((tm
40f0: 6f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 o (configf:looku
4100: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
4110: 65 72 76 65 72 22 20 22 74 69 6d 65 6f 75 74 22 erver" "timeout"
4120: 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ))). (if (and
4130: 20 28 73 74 72 69 6e 67 3f 20 74 6d 6f 29 0a 09 (string? tmo)..
4140: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 (common:hms
4150: 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 -string->seconds
4160: 20 74 6d 6f 29 29 0a 20 20 20 20 20 20 20 20 28 tmo)). (
4170: 2a 20 33 36 30 30 20 28 73 74 72 69 6e 67 2d 3e * 3600 (string->
4180: 6e 75 6d 62 65 72 20 74 6d 6f 29 29 0a 09 36 30 number tmo))..60
4190: 29 29 29 0a 0a 3b 3b 20 6d 6f 76 69 6e 67 20 74 )))..;; moving t
41a0: 68 69 73 20 68 65 72 65 20 61 73 20 69 74 20 6e his here as it n
41b0: 65 65 64 73 20 61 63 63 65 73 73 20 74 6f 20 64 eeds access to d
41c0: 62 20 61 6e 64 20 63 61 6e 6e 6f 74 20 62 65 20 b and cannot be
41d0: 69 6e 20 63 6f 6d 6d 6f 6e 2e 0a 3b 3b 0a 28 64 in common..;;.(d
41e0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 77 72 efine (server:wr
41f0: 69 74 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 20 itable-watchdog
4200: 64 62 73 74 72 75 63 74 29 0a 20 20 28 74 68 72 dbstruct). (thr
4210: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 ead-sleep! 0.05)
4220: 20 3b 3b 20 64 65 6c 61 79 20 66 6f 72 20 73 74 ;; delay for st
4230: 61 72 74 75 70 0a 20 20 28 6c 65 74 20 28 28 6c artup. (let ((l
4240: 65 67 61 63 79 2d 73 79 6e 63 20 20 28 63 6f 6d egacy-sync (com
4250: 6d 6f 6e 3a 72 75 6e 2d 73 79 6e 63 3f 29 29 0a mon:run-sync?)).
4260: 20 20 20 20 20 20 20 20 28 73 79 6e 63 2d 73 74 (sync-st
4270: 61 6c 65 2d 73 65 63 6f 6e 64 73 20 28 63 6f 6e ale-seconds (con
4280: 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 figf:lookup-numb
4290: 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 er *configdat* "
42a0: 73 65 72 76 65 72 22 20 22 73 79 6e 63 2d 73 74 server" "sync-st
42b0: 61 6c 65 2d 73 65 63 6f 6e 64 73 22 20 64 65 66 ale-seconds" def
42c0: 61 75 6c 74 3a 20 33 30 30 29 29 0a 09 28 64 65 ault: 300))..(de
42d0: 62 75 67 2d 6d 6f 64 65 20 20 20 28 64 65 62 75 bug-mode (debu
42e0: 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 29 g:debug-mode 1))
42f0: 0a 09 28 6c 61 73 74 2d 74 69 6d 65 20 20 20 20 ..(last-time
4300: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
4310: 29 29 0a 09 28 6e 6f 2d 73 79 6e 63 2d 64 62 20 ))..(no-sync-db
4320: 20 20 28 64 62 3a 6f 70 65 6e 2d 6e 6f 2d 73 79 (db:open-no-sy
4330: 6e 63 2d 64 62 29 29 0a 20 20 20 20 20 20 20 20 nc-db)).
4340: 28 73 79 6e 63 2d 64 75 72 61 74 69 6f 6e 20 30 (sync-duration 0
4350: 29 20 3b 3b 20 72 75 6e 20 74 69 6d 65 20 6f 66 ) ;; run time of
4360: 20 74 68 65 20 73 79 6e 63 20 69 6e 20 6d 69 6c the sync in mil
4370: 6c 69 73 65 63 6f 6e 64 73 0a 20 20 20 20 20 20 liseconds.
4380: 20 20 28 74 68 69 73 2d 77 64 2d 6e 75 6d 20 20 (this-wd-num
4390: 28 62 65 67 69 6e 20 28 6d 75 74 65 78 2d 6c 6f (begin (mutex-lo
43a0: 63 6b 21 20 2a 77 64 6e 75 6d 2a 6d 75 74 65 78 ck! *wdnum*mutex
43b0: 29 20 28 6c 65 74 20 28 28 78 20 2a 77 64 6e 75 ) (let ((x *wdnu
43c0: 6d 2a 29 29 20 28 73 65 74 21 20 2a 77 64 6e 75 m*)) (set! *wdnu
43d0: 6d 2a 20 28 61 64 64 31 20 2a 77 64 6e 75 6d 2a m* (add1 *wdnum*
43e0: 29 29 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b )) (mutex-unlock
43f0: 21 20 2a 77 64 6e 75 6d 2a 6d 75 74 65 78 29 20 ! *wdnum*mutex)
4400: 78 29 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 x)))). (set!
4410: 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 6e 6f 2d *no-sync-db* no-
4420: 73 79 6e 63 2d 64 62 29 20 3b 3b 20 6d 61 6b 65 sync-db) ;; make
4430: 20 74 68 65 20 6e 6f 20 73 79 6e 63 20 64 62 20 the no sync db
4440: 61 76 61 69 6c 61 62 6c 65 20 74 6f 20 61 70 69 available to api
4450: 20 63 61 6c 6c 73 0a 20 20 20 20 28 64 65 62 75 calls. (debu
4460: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a g:print-info 2 *
4470: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4480: 2a 20 22 50 65 72 69 6f 64 69 63 20 73 79 6e 63 * "Periodic sync
4490: 20 74 68 72 65 61 64 20 73 74 61 72 74 65 64 2e thread started.
44a0: 22 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 "). (debug:pr
44b0: 69 6e 74 2d 69 6e 66 6f 20 33 20 2a 64 65 66 61 int-info 3 *defa
44c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 ult-log-port* "w
44d0: 61 74 63 68 64 6f 67 20 73 74 61 72 74 69 6e 67 atchdog starting
44e0: 2e 20 6c 65 67 61 63 79 2d 73 79 6e 63 20 69 73 . legacy-sync is
44f0: 20 22 20 6c 65 67 61 63 79 2d 73 79 6e 63 22 20 " legacy-sync"
4500: 70 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 pid="(current-pr
4510: 6f 63 65 73 73 2d 69 64 29 22 20 74 68 69 73 2d ocess-id)" this-
4520: 77 64 2d 6e 75 6d 3d 22 74 68 69 73 2d 77 64 2d wd-num="this-wd-
4530: 6e 75 6d 29 0a 20 20 20 20 28 69 66 20 28 61 6e num). (if (an
4540: 64 20 6c 65 67 61 63 79 2d 73 79 6e 63 20 28 6e d legacy-sync (n
4550: 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 ot *time-to-exit
4560: 2a 29 29 0a 09 28 6c 65 74 2a 20 28 3b 3b 28 64 *))..(let* (;;(d
4570: 62 73 74 72 75 63 74 20 28 64 62 3a 73 65 74 75 bstruct (db:setu
4580: 70 29 29 0a 09 20 20 20 20 20 20 20 28 6d 74 64 p)).. (mtd
4590: 62 20 20 20 20 20 20 20 28 64 62 72 3a 64 62 73 b (dbr:dbs
45a0: 74 72 75 63 74 2d 6d 74 64 62 20 64 62 73 74 72 truct-mtdb dbstr
45b0: 75 63 74 29 29 0a 09 20 20 20 20 20 20 20 28 6d uct)).. (m
45c0: 74 70 61 74 68 20 20 20 20 20 28 64 62 3a 64 62 tpath (db:db
45d0: 64 61 74 2d 67 65 74 2d 70 61 74 68 20 6d 74 64 dat-get-path mtd
45e0: 62 29 29 0a 09 20 20 20 20 20 20 20 28 74 6d 70 b)).. (tmp
45f0: 2d 61 72 65 61 20 20 20 28 63 6f 6d 6d 6f 6e 3a -area (common:
4600: 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 get-db-tmp-area)
4610: 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 72 74 ).. (start
4620: 2d 66 69 6c 65 20 28 63 6f 6e 63 20 74 6d 70 2d -file (conc tmp-
4630: 61 72 65 61 20 22 2f 2e 73 74 61 72 74 2d 73 79 area "/.start-sy
4640: 6e 63 22 29 29 0a 09 20 20 20 20 20 20 20 28 65 nc")).. (e
4650: 6e 64 2d 66 69 6c 65 20 20 20 28 63 6f 6e 63 20 nd-file (conc
4660: 74 6d 70 2d 61 72 65 61 20 22 2f 2e 65 6e 64 2d tmp-area "/.end-
4670: 73 79 6e 63 22 29 29 29 0a 09 20 20 28 64 65 62 sync"))).. (deb
4680: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
4690: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
46a0: 74 2a 20 22 53 65 72 76 65 72 20 72 75 6e 6e 69 t* "Server runni
46b0: 6e 67 2c 20 70 65 72 69 6f 64 69 63 20 73 79 6e ng, periodic syn
46c0: 63 20 73 74 61 72 74 65 64 2e 22 29 0a 09 20 20 c started.")..
46d0: 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 09 20 20 (let loop ()..
46e0: 20 20 3b 3b 20 73 79 6e 63 20 66 6f 72 20 66 69 ;; sync for fi
46f0: 6c 65 73 79 73 74 65 6d 20 6c 6f 63 61 6c 20 64 lesystem local d
4700: 62 20 77 72 69 74 65 73 0a 09 20 20 20 20 3b 3b b writes.. ;;
4710: 0a 09 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 .. (mutex-loc
4720: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
4730: 63 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 28 c-mutex*).. (
4740: 6c 65 74 2a 20 28 28 6e 65 65 64 2d 73 79 6e 63 let* ((need-sync
4750: 20 20 20 20 20 20 20 20 28 3e 3d 20 2a 64 62 2d (>= *db-
4760: 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 2a 64 62 last-access* *db
4770: 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 29 20 3b 3b -last-sync*)) ;;
4780: 20 6e 6f 20 73 79 6e 63 20 73 69 6e 63 65 20 6c no sync since l
4790: 61 73 74 20 77 72 69 74 65 0a 09 09 20 20 20 28 ast write... (
47a0: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
47b0: 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f *db-sync-in-pro
47c0: 67 72 65 73 73 2a 29 0a 09 09 20 20 20 28 73 68 gress*)... (sh
47d0: 6f 75 6c 64 2d 73 79 6e 63 20 20 20 20 20 20 28 ould-sync (
47e0: 61 6e 64 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 and (not *time-t
47f0: 6f 2d 65 78 69 74 2a 29 0a 20 20 20 20 20 20 20 o-exit*).
4800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4820: 20 20 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e (> (- (curren
4830: 74 2d 73 65 63 6f 6e 64 73 29 20 2a 64 62 2d 6c t-seconds) *db-l
4840: 61 73 74 2d 73 79 6e 63 2a 29 20 35 29 29 29 20 ast-sync*) 5)))
4850: 3b 3b 20 73 79 6e 63 20 65 76 65 72 79 20 66 69 ;; sync every fi
4860: 76 65 20 73 65 63 6f 6e 64 73 20 6d 69 6e 69 6d ve seconds minim
4870: 75 6d 2c 20 64 65 70 72 65 63 61 74 65 64 20 6c um, deprecated l
4880: 6f 67 69 63 2c 20 63 61 6e 20 70 72 6f 62 61 62 ogic, can probab
4890: 6c 79 20 62 65 20 72 65 6d 6f 76 65 64 0a 09 09 ly be removed...
48a0: 20 20 20 28 73 74 61 72 74 2d 74 69 6d 65 20 20 (start-time
48b0: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 (current-se
48c0: 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 20 20 conds)).
48d0: 20 20 20 20 20 20 20 20 20 20 20 28 63 70 75 2d (cpu-
48e0: 6c 6f 61 64 2d 61 64 6a 20 20 20 20 20 28 61 6c load-adj (al
48f0: 69 73 74 2d 72 65 66 20 27 61 64 6a 2d 70 72 6f ist-ref 'adj-pro
4900: 63 2d 6c 6f 61 64 20 28 63 6f 6d 6d 6f 6e 3a 67 c-load (common:g
4910: 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 et-normalized-cp
4920: 75 2d 6c 6f 61 64 20 23 66 29 29 29 0a 09 09 20 u-load #f)))...
4930: 20 20 28 6d 74 2d 6d 6f 64 2d 74 69 6d 65 20 20 (mt-mod-time
4940: 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 (file-modifi
4950: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6d 74 70 61 cation-time mtpa
4960: 74 68 29 29 0a 09 09 20 20 20 28 6c 61 73 74 2d th))... (last-
4970: 73 79 6e 63 2d 73 74 61 72 74 20 20 28 69 66 20 sync-start (if
4980: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
4990: 73 74 73 3f 20 73 74 61 72 74 2d 66 69 6c 65 29 sts? start-file)
49a0: 0a 09 09 09 09 09 20 28 66 69 6c 65 2d 6d 6f 64 ...... (file-mod
49b0: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 ification-time s
49c0: 74 61 72 74 2d 66 69 6c 65 29 0a 09 09 09 09 09 tart-file)......
49d0: 20 30 29 29 0a 09 09 20 20 20 28 6c 61 73 74 2d 0))... (last-
49e0: 73 79 6e 63 2d 65 6e 64 20 20 20 20 28 69 66 20 sync-end (if
49f0: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
4a00: 73 74 73 3f 20 65 6e 64 2d 66 69 6c 65 29 0a 09 sts? end-file)..
4a10: 09 09 09 09 20 28 66 69 6c 65 2d 6d 6f 64 69 66 .... (file-modif
4a20: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 65 6e 64 ication-time end
4a30: 2d 66 69 6c 65 29 0a 09 09 09 09 09 20 31 30 29 -file)...... 10)
4a40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4a50: 20 20 20 20 20 28 73 79 6e 63 2d 70 65 72 69 6f (sync-perio
4a60: 64 20 20 20 20 20 20 28 2b 20 33 20 28 2a 20 63 d (+ 3 (* c
4a70: 70 75 2d 6c 6f 61 64 2d 61 64 6a 20 33 30 29 29 pu-load-adj 30))
4a80: 29 20 3b 3b 20 61 73 20 61 64 6a 75 73 74 65 64 ) ;; as adjusted
4a90: 20 6c 6f 61 64 20 69 6e 63 72 65 61 73 65 73 20 load increases
4aa0: 69 6e 63 72 65 61 73 65 20 74 68 65 20 73 79 6e increase the syn
4ab0: 63 20 70 65 72 69 6f 64 0a 09 09 20 20 20 28 72 c period... (r
4ac0: 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 20 20 ecently-synced
4ad0: 28 61 6e 64 20 28 3c 20 28 2d 20 73 74 61 72 74 (and (< (- start
4ae0: 2d 74 69 6d 65 20 6d 74 2d 6d 6f 64 2d 74 69 6d -time mt-mod-tim
4af0: 65 29 20 73 79 6e 63 2d 70 65 72 69 6f 64 29 20 e) sync-period)
4b00: 3b 3b 20 6e 6f 74 20 75 73 65 66 75 6c 20 69 66 ;; not useful if
4b10: 20 73 79 6e 63 20 64 69 64 6e 27 74 20 6d 6f 64 sync didn't mod
4b20: 69 66 79 20 6d 65 67 61 74 65 73 74 2e 64 62 21 ify megatest.db!
4b30: 0a 09 09 09 09 09 20 20 28 3c 20 6d 74 2d 6d 6f ...... (< mt-mo
4b40: 64 2d 74 69 6d 65 20 6c 61 73 74 2d 73 79 6e 63 d-time last-sync
4b50: 2d 73 74 61 72 74 29 29 29 0a 09 09 20 20 20 28 -start)))... (
4b60: 73 79 6e 63 2d 64 6f 6e 65 20 20 20 20 20 20 20 sync-done
4b70: 20 28 3c 3d 20 6c 61 73 74 2d 73 79 6e 63 2d 73 (<= last-sync-s
4b80: 74 61 72 74 20 6c 61 73 74 2d 73 79 6e 63 2d 65 tart last-sync-e
4b90: 6e 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 nd)).
4ba0: 20 20 20 20 20 20 20 20 28 73 79 6e 63 2d 73 74 (sync-st
4bb0: 61 6c 65 20 20 20 20 20 20 20 28 3e 20 73 74 61 ale (> sta
4bc0: 72 74 2d 74 69 6d 65 20 28 2b 20 6c 61 73 74 2d rt-time (+ last-
4bd0: 73 79 6e 63 2d 73 74 61 72 74 20 73 79 6e 63 2d sync-start sync-
4be0: 73 74 61 6c 65 2d 73 65 63 6f 6e 64 73 29 29 29 stale-seconds)))
4bf0: 0a 09 09 20 20 20 28 77 69 6c 6c 2d 73 79 6e 63 ... (will-sync
4c00: 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 6e 6f (and (no
4c10: 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a t *time-to-exit*
4c20: 29 20 20 20 20 20 20 20 3b 3b 20 64 6f 20 6e 6f ) ;; do no
4c30: 74 20 73 74 61 72 74 20 61 20 73 79 6e 63 20 69 t start a sync i
4c40: 66 20 77 65 20 61 72 65 20 69 6e 20 74 68 65 20 f we are in the
4c50: 70 72 6f 63 65 73 73 20 6f 66 20 65 78 69 74 69 process of exiti
4c60: 6e 67 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ng.
4c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 72 (or
4c90: 20 6e 65 65 64 2d 73 79 6e 63 20 73 68 6f 75 6c need-sync shoul
4ca0: 64 2d 73 79 6e 63 29 0a 09 09 09 09 09 20 20 28 d-sync)...... (
4cb0: 6f 72 20 73 79 6e 63 2d 64 6f 6e 65 20 73 79 6e or sync-done syn
4cc0: 63 2d 73 74 61 6c 65 29 0a 09 09 09 09 09 20 20 c-stale)......
4cd0: 28 6e 6f 74 20 73 79 6e 63 2d 69 6e 2d 70 72 6f (not sync-in-pro
4ce0: 67 72 65 73 73 29 0a 09 09 09 09 09 20 20 28 6e gress)...... (n
4cf0: 6f 74 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 ot recently-sync
4d00: 65 64 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 ed)))).
4d10: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
4d20: 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 t-info 13 *defau
4d30: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 44 lt-log-port* "WD
4d40: 20 77 72 69 74 61 62 6c 65 2d 77 61 74 63 68 64 writable-watchd
4d50: 6f 67 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 2e 20 og top of loop.
4d60: 20 6e 65 65 64 2d 73 79 6e 63 3d 22 6e 65 65 64 need-sync="need
4d70: 2d 73 79 6e 63 22 20 73 79 6e 63 2d 69 6e 2d 70 -sync" sync-in-p
4d80: 72 6f 67 72 65 73 73 3d 22 20 73 79 6e 63 2d 69 rogress=" sync-i
4d90: 6e 2d 70 72 6f 67 72 65 73 73 0a 09 09 09 09 22 n-progress....."
4da0: 20 73 68 6f 75 6c 64 2d 73 79 6e 63 3d 22 73 68 should-sync="sh
4db0: 6f 75 6c 64 2d 73 79 6e 63 22 20 73 74 61 72 74 ould-sync" start
4dc0: 2d 74 69 6d 65 3d 22 73 74 61 72 74 2d 74 69 6d -time="start-tim
4dd0: 65 22 20 6d 74 2d 6d 6f 64 2d 74 69 6d 65 3d 22 e" mt-mod-time="
4de0: 6d 74 2d 6d 6f 64 2d 74 69 6d 65 22 20 72 65 63 mt-mod-time" rec
4df0: 65 6e 74 6c 79 2d 73 79 6e 63 65 64 3d 22 72 65 ently-synced="re
4e00: 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 22 20 77 cently-synced" w
4e10: 69 6c 6c 2d 73 79 6e 63 3d 22 77 69 6c 6c 2d 73 ill-sync="will-s
4e20: 79 6e 63 0a 09 09 09 09 22 20 73 79 6e 63 2d 64 ync....." sync-d
4e30: 6f 6e 65 3d 22 20 73 79 6e 63 2d 64 6f 6e 65 20 one=" sync-done
4e40: 22 20 73 79 6e 63 2d 70 65 72 69 6f 64 3d 22 20 " sync-period="
4e50: 73 79 6e 63 2d 70 65 72 69 6f 64 29 0a 20 20 20 sync-period).
4e60: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
4e70: 61 6e 64 20 28 3e 20 73 79 6e 63 2d 70 65 72 69 and (> sync-peri
4e80: 6f 64 20 35 29 0a 20 20 20 20 20 20 20 20 20 20 od 5).
4e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
4ea0: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
4eb0: 72 69 6e 74 20 33 30 20 22 73 79 6e 63 2d 70 65 rint 30 "sync-pe
4ec0: 72 69 6f 64 22 29 29 0a 20 20 20 20 20 20 20 20 riod")).
4ed0: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
4ee0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
4ef0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4f00: 20 22 49 6e 63 72 65 61 73 65 64 20 73 79 6e 63 "Increased sync
4f10: 20 70 65 72 69 6f 64 20 64 75 65 20 74 6f 20 6c period due to l
4f20: 6f 61 64 3a 20 22 20 73 79 6e 63 2d 70 65 72 69 oad: " sync-peri
4f30: 6f 64 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 od)).. ;; (
4f40: 69 66 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 if recently-sync
4f50: 65 64 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ed (debug:print-
4f60: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
4f70: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 6b 69 70 70 log-port* "Skipp
4f80: 69 6e 67 20 73 79 6e 63 20 64 75 65 20 74 6f 20 ing sync due to
4f90: 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 20 recently-synced
4fa0: 66 6c 61 67 3d 22 20 72 65 63 65 6e 74 6c 79 2d flag=" recently-
4fb0: 73 79 6e 63 65 64 29 29 0a 09 20 20 20 20 20 20 synced))..
4fc0: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ;; (debug:print-
4fd0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
4fe0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 65 65 64 2d log-port* "need-
4ff0: 73 79 6e 63 3a 20 22 20 6e 65 65 64 2d 73 79 6e sync: " need-syn
5000: 63 20 22 20 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 c " sync-in-prog
5010: 72 65 73 73 3a 20 22 20 73 79 6e 63 2d 69 6e 2d ress: " sync-in-
5020: 70 72 6f 67 72 65 73 73 20 22 20 73 68 6f 75 6c progress " shoul
5030: 64 2d 73 79 6e 63 3a 20 22 20 73 68 6f 75 6c 64 d-sync: " should
5040: 2d 73 79 6e 63 20 22 20 77 69 6c 6c 2d 73 79 6e -sync " will-syn
5050: 63 3a 20 22 20 77 69 6c 6c 2d 73 79 6e 63 29 0a c: " will-sync).
5060: 09 20 20 20 20 20 20 28 69 66 20 77 69 6c 6c 2d . (if will-
5070: 73 79 6e 63 20 28 73 65 74 21 20 2a 64 62 2d 73 sync (set! *db-s
5080: 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a ync-in-progress*
5090: 20 23 74 29 29 0a 09 20 20 20 20 20 20 28 6d 75 #t)).. (mu
50a0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d tex-unlock! *db-
50b0: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
50c0: 2a 29 0a 09 20 20 20 20 20 20 28 69 66 20 77 69 *).. (if wi
50d0: 6c 6c 2d 73 79 6e 63 0a 20 20 20 20 20 20 20 20 ll-sync.
50e0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
50f0: 28 73 79 6e 63 2d 73 74 61 72 74 20 28 63 75 72 (sync-start (cur
5100: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
5110: 73 29 29 29 0a 09 09 20 20 20 20 28 77 69 74 68 s)))... (with
5120: 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 -output-to-file
5130: 73 74 61 72 74 2d 66 69 6c 65 20 28 6c 61 6d 62 start-file (lamb
5140: 64 61 20 28 29 28 70 72 69 6e 74 20 28 63 75 72 da ()(print (cur
5150: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
5160: 29 29 29 0a 09 09 20 20 20 20 0a 09 09 20 20 20 )))... ...
5170: 20 3b 3b 20 70 75 74 20 6c 6f 63 6b 20 68 65 72 ;; put lock her
5180: 65 0a 09 09 20 20 20 20 0a 20 20 20 20 20 20 20 e... .
5190: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
51a0: 20 28 3c 20 73 79 6e 63 2d 64 75 72 61 74 69 6f (< sync-duratio
51b0: 6e 20 33 30 30 30 29 20 3b 3b 20 4e 4f 54 45 3a n 3000) ;; NOTE:
51c0: 20 64 62 3a 73 79 6e 63 2d 74 6f 2d 6d 65 67 61 db:sync-to-mega
51d0: 74 65 73 74 2e 64 62 20 6b 65 65 70 73 20 74 72 test.db keeps tr
51e0: 61 63 6b 20 6f 66 20 74 69 6d 65 20 6f 66 20 6c ack of time of l
51f0: 61 73 74 20 73 79 6e 63 20 61 6e 64 20 73 79 6e ast sync and syn
5200: 63 73 20 69 6e 63 72 65 6d 65 6e 74 61 6c 6c 79 cs incrementally
5210: 0a 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 28 6c 65 74 20 28 28 (let ((
5230: 72 65 73 20 20 20 20 20 20 20 20 28 64 62 3a 73 res (db:s
5240: 79 6e 63 2d 74 6f 2d 6d 65 67 61 74 65 73 74 2e ync-to-megatest.
5250: 64 62 20 64 62 73 74 72 75 63 74 20 6e 6f 2d 73 db dbstruct no-s
5260: 79 6e 63 2d 64 62 3a 20 6e 6f 2d 73 79 6e 63 2d ync-db: no-sync-
5270: 64 62 29 29 29 20 3b 3b 20 64 69 64 20 77 65 20 db))) ;; did we
5280: 73 79 6e 63 20 61 6e 79 20 64 61 74 61 3f 20 49 sync any data? I
5290: 66 20 73 6f 20 6e 65 65 64 20 74 6f 20 73 65 74 f so need to set
52a0: 20 74 68 65 20 64 62 20 74 6f 75 63 68 65 64 20 the db touched
52b0: 66 6c 61 67 20 74 6f 20 6b 65 65 70 20 74 68 65 flag to keep the
52c0: 20 73 65 72 76 65 72 20 61 6c 69 76 65 0a 20 20 server alive.
52d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52e0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 73 79 (set! sy
52f0: 6e 63 2d 64 75 72 61 74 69 6f 6e 20 28 2d 20 28 nc-duration (- (
5300: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
5310: 6f 6e 64 73 29 20 73 79 6e 63 2d 73 74 61 72 74 onds) sync-start
5320: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5330: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
5340: 20 28 3e 20 72 65 73 20 30 29 20 3b 3b 20 73 6f (> res 0) ;; so
5350: 6d 65 20 72 65 63 6f 72 64 73 20 77 65 72 65 20 me records were
5360: 74 72 61 6e 73 66 65 72 72 65 64 2c 20 6b 65 65 transferred, kee
5370: 70 20 74 68 65 20 64 62 20 61 6c 69 76 65 0a 20 p the db alive.
5380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5390: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
53a0: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
53b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
53c0: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
53d0: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
53e0: 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 x*).
53f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5400: 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 (set! *db-la
5410: 73 74 2d 61 63 63 65 73 73 2a 20 28 63 75 72 72 st-access* (curr
5420: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 ent-seconds)).
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 28 6d (m
5450: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 utex-unlock! *he
5460: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
5470: 20 20 20 20 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 20 20 20
5490: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
54a0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
54b0: 2d 70 6f 72 74 2a 20 22 73 79 6e 63 20 63 61 6c -port* "sync cal
54c0: 6c 65 64 2c 20 22 20 72 65 73 20 22 20 72 65 63 led, " res " rec
54d0: 6f 72 64 73 20 74 72 61 6e 73 66 65 72 72 65 64 ords transferred
54e0: 2e 22 29 29 0a 20 20 20 20 20 20 20 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 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5510: 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d info 2 *default-
5520: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 79 6e 63 20 log-port* "sync
5530: 63 61 6c 6c 65 64 20 62 75 74 20 7a 65 72 6f 20 called but zero
5540: 72 65 63 6f 72 64 73 20 74 72 61 6e 73 66 65 72 records transfer
5550: 72 65 64 22 29 29 29 0a 20 20 20 20 20 20 20 20 red"))).
5560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5570: 3b 3b 20 54 4f 44 4f 3a 20 66 61 63 74 6f 72 20 ;; TODO: factor
5580: 74 68 69 73 20 6e 65 78 74 20 72 6f 75 74 69 6e this next routin
5590: 65 20 6f 75 74 20 69 6e 74 6f 20 61 20 66 75 6e e out into a fun
55a0: 63 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 20 20 ction.
55b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 (w
55c0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
55d0: 69 70 65 20 3b 3b 20 74 68 69 73 20 73 68 6f 75 ipe ;; this shou
55e0: 6c 64 20 6e 6f 74 20 62 6c 6f 63 6b 20 6f 74 68 ld not block oth
55f0: 65 72 20 74 68 72 65 61 64 73 20 62 75 74 20 6e er threads but n
5600: 65 65 64 20 74 6f 20 76 65 72 69 66 79 20 74 68 eed to verify th
5610: 69 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 is.
5620: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
5630: 63 20 22 6d 65 67 61 74 65 73 74 20 2d 73 79 6e c "megatest -syn
5640: 63 2d 74 6f 2d 6d 65 67 61 74 65 73 74 2e 64 62 c-to-megatest.db
5650: 20 2d 6d 20 74 65 73 74 73 75 69 74 65 3a 22 20 -m testsuite:"
5660: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 (common:get-area
5670: 2d 6e 61 6d 65 29 20 22 3a 22 20 2a 74 6f 70 70 -name) ":" *topp
5680: 61 74 68 2a 29 0a 20 20 20 20 20 20 20 20 20 20 ath*).
5690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
56a0: 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 lambda ().
56b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56c0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
56d0: 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 29 (inl (read-line)
56e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
56f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5700: 20 20 20 20 20 20 20 20 28 72 65 73 20 23 66 29 (res #f)
5710: 29 0a 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 20 20 20 28 (
5730: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
5740: 69 6e 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 inl).
5750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5760: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
5770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5790: 28 73 65 74 21 20 73 79 6e 63 2d 64 75 72 61 74 (set! sync-durat
57a0: 69 6f 6e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d ion (- (current-
57b0: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 79 milliseconds) sy
57c0: 6e 63 2d 73 74 61 72 74 29 29 0a 20 20 20 20 20 nc-start)).
57d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
57f0: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 ond.
5800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5810: 20 20 20 20 20 20 20 20 28 28 6e 6f 74 20 72 65 ((not re
5820: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s).
5830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5840: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
5850: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
5860: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
5870: 3a 20 73 79 6e 63 20 66 72 6f 6d 20 2f 74 6d 70 : sync from /tmp
5880: 20 64 62 20 74 6f 20 6d 65 67 61 74 65 73 74 2e db to megatest.
5890: 64 62 20 61 70 70 65 61 72 73 20 74 6f 20 68 61 db appears to ha
58a0: 76 65 20 66 61 69 6c 65 64 2e 20 52 65 63 6f 6d ve failed. Recom
58b0: 6d 65 6e 64 65 64 20 74 68 61 74 20 79 6f 75 20 mended that you
58c0: 73 74 6f 70 20 79 6f 75 72 20 72 75 6e 73 20 61 stop your runs a
58d0: 6e 64 20 72 75 6e 20 5c 22 6d 65 67 61 74 65 73 nd run \"megates
58e0: 74 20 2d 63 6c 65 61 6e 75 70 2d 64 62 5c 22 22 t -cleanup-db\""
58f0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5910: 20 20 20 20 20 20 20 28 28 3e 20 72 65 73 20 30 ((> res 0
5920: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5940: 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f (mutex-lo
5950: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
5960: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 utex*).
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 28 73 65 74 (set
5990: 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 ! *db-last-acces
59a0: 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f s* (current-seco
59b0: 6e 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 nds)).
59c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
59d0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 (mute
59e0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 x-unlock! *heart
59f0: 62 65 61 74 2d 6d 75 74 65 78 2a 29 29 29 29 0a beat-mutex*)))).
5a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a20: 20 28 6c 65 74 20 28 28 6e 75 6d 2d 73 79 6e 63 (let ((num-sync
5a30: 65 64 20 28 6c 65 74 20 28 28 6d 61 74 63 68 65 ed (let ((matche
5a40: 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 s (string-match
5a50: 22 5e 53 79 6e 63 65 64 20 28 5c 5c 64 2b 29 2e "^Synced (\\d+).
5a60: 2a 24 22 20 69 6e 6c 29 29 29 0a 20 20 20 20 20 *$" inl))).
5a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5aa0: 28 69 66 20 6d 61 74 63 68 65 73 0a 20 20 20 20 (if matches.
5ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 20 20
5ae0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
5af0: 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 mber (cadr match
5b00: 65 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 es)).
5b10: 20 20 20 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 20 20 23 66 #f
5b40: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
5b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b60: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 (loop (r
5b70: 65 61 64 2d 6c 69 6e 65 29 0a 20 20 20 20 20 20 ead-line).
5b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ba0: 20 20 20 28 6f 72 20 6e 75 6d 2d 73 79 6e 63 65 (or num-synce
5bb0: 64 20 72 65 73 29 29 29 29 29 29 29 29 29 29 0a d res)))))))))).
5bc0: 09 20 20 20 20 20 20 28 69 66 20 77 69 6c 6c 2d . (if will-
5bd0: 73 79 6e 63 0a 09 09 20 20 28 62 65 67 69 6e 0a sync... (begin.
5be0: 09 09 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 .. (mutex-loc
5bf0: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
5c00: 63 2d 6d 75 74 65 78 2a 29 0a 09 09 20 20 20 20 c-mutex*)...
5c10: 28 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 (set! *db-sync-i
5c20: 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 66 29 0a n-progress* #f).
5c30: 09 09 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d .. (set! *db-
5c40: 6c 61 73 74 2d 73 79 6e 63 2a 20 73 74 61 72 74 last-sync* start
5c50: 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 28 77 69 -time)... (wi
5c60: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c th-output-to-fil
5c70: 65 20 65 6e 64 2d 66 69 6c 65 20 28 6c 61 6d 62 e end-file (lamb
5c80: 64 61 20 28 29 28 70 72 69 6e 74 20 28 63 75 72 da ()(print (cur
5c90: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
5ca0: 29 29 29 0a 0a 09 09 20 20 20 20 3b 3b 20 72 65 ))).... ;; re
5cb0: 6c 65 61 73 65 20 6c 6f 63 6b 20 68 65 72 65 0a lease lock here.
5cc0: 0a 09 09 20 20 20 20 28 6d 75 74 65 78 2d 75 6e ... (mutex-un
5cd0: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
5ce0: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 29 29 0a 09 sync-mutex*)))..
5cf0: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 64 (if (and d
5d00: 65 62 75 67 2d 6d 6f 64 65 0a 09 09 20 20 20 20 ebug-mode...
5d10: 20 20 20 28 3e 20 28 2d 20 73 74 61 72 74 2d 74 (> (- start-t
5d20: 69 6d 65 20 6c 61 73 74 2d 74 69 6d 65 29 20 36 ime last-time) 6
5d30: 30 29 29 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 0))... (begin..
5d40: 09 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 2d . (set! last-
5d50: 74 69 6d 65 20 73 74 61 72 74 2d 74 69 6d 65 29 time start-time)
5d60: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
5d70: 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 int-info 4 *defa
5d80: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 ult-log-port* "t
5d90: 69 6d 65 73 74 61 6d 70 20 2d 3e 20 22 20 28 73 imestamp -> " (s
5da0: 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 econds->time-str
5db0: 69 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ing (current-sec
5dc0: 6f 6e 64 73 29 29 20 22 2c 20 74 69 6d 65 20 73 onds)) ", time s
5dd0: 69 6e 63 65 20 73 74 61 72 74 20 2d 3e 20 22 20 ince start -> "
5de0: 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e (seconds->hr-min
5df0: 2d 73 65 63 20 28 2d 20 28 63 75 72 72 65 6e 74 -sec (- (current
5e00: 2d 73 65 63 6f 6e 64 73 29 20 2a 74 69 6d 65 2d -seconds) *time-
5e10: 7a 65 72 6f 2a 29 29 29 29 29 29 0a 09 20 20 20 zero*))))))..
5e20: 20 0a 09 20 20 20 20 3b 3b 20 6b 65 65 70 20 67 .. ;; keep g
5e30: 6f 69 6e 67 20 75 6e 6c 65 73 73 20 74 69 6d 65 oing unless time
5e40: 20 74 6f 20 65 78 69 74 0a 09 20 20 20 20 3b 3b to exit.. ;;
5e50: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 2a .. (if (not *
5e60: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 time-to-exit*)..
5e70: 09 28 6c 65 74 20 64 65 6c 61 79 2d 6c 6f 6f 70 .(let delay-loop
5e80: 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 ((count 0)).
5e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
5ea0: 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e ;(debug:print-in
5eb0: 66 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c fo 13 *default-l
5ec0: 6f 67 2d 70 6f 72 74 2a 20 22 64 65 6c 61 79 2d og-port* "delay-
5ed0: 6c 6f 6f 70 20 74 6f 70 3b 20 63 6f 75 6e 74 3d loop top; count=
5ee0: 22 63 6f 75 6e 74 22 20 70 69 64 3d 22 28 63 75 "count" pid="(cu
5ef0: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
5f00: 29 22 20 74 68 69 73 2d 77 64 2d 6e 75 6d 3d 22 )" this-wd-num="
5f10: 74 68 69 73 2d 77 64 2d 6e 75 6d 22 20 2a 74 69 this-wd-num" *ti
5f20: 6d 65 2d 74 6f 2d 65 78 69 74 2a 3d 22 2a 74 69 me-to-exit*="*ti
5f30: 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 20 20 me-to-exit*).
5f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f70: 20 20 20 20 20 20 20 20 20 0a 09 09 20 20 28 69 ... (i
5f80: 66 20 28 61 6e 64 20 28 6e 6f 74 20 2a 74 69 6d f (and (not *tim
5f90: 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 09 09 20 e-to-exit*)....
5fa0: 20 20 28 3c 20 63 6f 75 6e 74 20 36 29 29 20 3b (< count 6)) ;
5fb0: 3b 20 77 61 73 20 31 31 2c 20 63 68 61 6e 67 69 ; was 11, changi
5fc0: 6e 67 20 74 6f 20 34 2e 20 0a 09 09 20 20 20 20 ng to 4. ...
5fd0: 20 20 28 62 65 67 69 6e 0a 09 09 09 28 74 68 72 (begin....(thr
5fe0: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 ead-sleep! 1)...
5ff0: 09 28 64 65 6c 61 79 2d 6c 6f 6f 70 20 28 2b 20 .(delay-loop (+
6000: 63 6f 75 6e 74 20 31 29 29 29 29 0a 09 09 20 20 count 1))))...
6010: 28 69 66 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 (if (not *time-t
6020: 6f 2d 65 78 69 74 2a 29 20 28 6c 6f 6f 70 29 29 o-exit*) (loop))
6030: 29 29 0a 09 20 20 20 20 3b 3b 20 74 69 6d 65 20 )).. ;; time
6040: 74 6f 20 65 78 69 74 2c 20 63 6c 6f 73 65 20 74 to exit, close t
6050: 68 65 20 6e 6f 2d 73 79 6e 63 20 64 62 20 68 65 he no-sync db he
6060: 72 65 0a 09 20 20 20 20 28 64 62 3a 6e 6f 2d 73 re.. (db:no-s
6070: 79 6e 63 2d 63 6c 6f 73 65 2d 64 62 20 6e 6f 2d ync-close-db no-
6080: 73 79 6e 63 2d 64 62 29 0a 09 20 20 20 20 28 69 sync-db).. (i
6090: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
60a0: 69 73 65 2d 70 72 69 6e 74 20 33 30 29 0a 09 09 ise-print 30)...
60b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
60c0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
60d0: 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 -port* "Exiting
60e0: 77 61 74 63 68 64 6f 67 20 74 69 6d 65 72 2c 20 watchdog timer,
60f0: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3d *time-to-exit* =
6100: 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 " *time-to-exit
6110: 2a 22 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 *" pid="(current
6120: 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 74 68 -process-id)" th
6130: 69 73 2d 77 64 2d 6e 75 6d 3d 22 74 68 69 73 2d is-wd-num="this-
6140: 77 64 2d 6e 75 6d 29 29 29 29 29 29 29 0a 0a wd-num)))))))..