0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 31 37 2c 20 4d 61 74 74 right 2017, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 74 63 70 2d 74 72 61 6e 73 70 6f unit tcp-transpo
03a0: 72 74 6d 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 rtmod)).(declare
03b0: 20 28 75 73 65 73 20 64 65 62 75 67 70 72 69 6e (uses debugprin
03c0: 74 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 t)).(declare (us
03d0: 65 73 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a 28 es commonmod)).(
03e0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 declare (uses db
03f0: 66 69 6c 65 29 29 0a 28 64 65 63 6c 61 72 65 20 file)).(declare
0400: 28 75 73 65 73 20 64 62 6d 6f 64 29 29 0a 28 64 (uses dbmod)).(d
0410: 65 63 6c 61 72 65 20 28 75 73 65 73 20 70 6f 72 eclare (uses por
0420: 74 6c 6f 67 67 65 72 29 29 0a 28 64 65 63 6c 61 tlogger)).(decla
0430: 72 65 20 28 75 73 65 73 20 6d 74 6d 6f 64 29 29 re (uses mtmod))
0440: 0a 0a 28 75 73 65 20 61 64 64 72 65 73 73 2d 69 ..(use address-i
0450: 6e 66 6f 20 74 63 70 29 0a 0a 28 6d 6f 64 75 6c nfo tcp)..(modul
0460: 65 20 74 63 70 2d 74 72 61 6e 73 70 6f 72 74 6d e tcp-transportm
0470: 6f 64 0a 09 2a 0a 09 0a 28 69 6d 70 6f 72 74 20 od..*...(import
0480: 73 63 68 65 6d 65 29 0a 0a 28 63 6f 6e 64 2d 65 scheme)..(cond-e
0490: 78 70 61 6e 64 0a 20 28 63 68 69 63 6b 65 6e 2d xpand. (chicken-
04a0: 34 0a 20 20 28 69 6d 70 6f 72 74 20 28 70 72 65 4. (import (pre
04b0: 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 fix sqlite3 sqli
04c0: 74 65 33 3a 29 0a 09 20 20 63 68 69 63 6b 65 6e te3:).. chicken
04d0: 0a 09 20 20 65 78 74 72 61 73 0a 09 20 20 68 6f .. extras.. ho
04e0: 73 74 69 6e 66 6f 0a 0a 09 20 20 70 6f 72 74 73 stinfo... ports
04f0: 0a 09 20 20 70 6f 73 69 78 0a 09 20 20 66 69 6c .. posix.. fil
0500: 65 73 0a 09 20 20 64 61 74 61 2d 73 74 72 75 63 es.. data-struc
0510: 74 75 72 65 73 0a 09 20 20 74 63 70 0a 09 20 20 tures.. tcp..
0520: 29 29 0a 20 28 63 68 69 63 6b 65 6e 2d 35 0a 20 )). (chicken-5.
0530: 20 28 69 6d 70 6f 72 74 20 63 68 69 63 6b 65 6e (import chicken
0540: 2e 62 61 73 65 0a 09 20 20 63 68 69 63 6b 65 6e .base.. chicken
0550: 2e 63 6f 6e 64 69 74 69 6f 6e 0a 09 20 20 63 68 .condition.. ch
0560: 69 63 6b 65 6e 2e 66 69 6c 65 0a 09 20 20 63 68 icken.file.. ch
0570: 69 63 6b 65 6e 2e 70 61 74 68 6e 61 6d 65 0a 09 icken.pathname..
0580: 20 20 63 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 chicken.proces
0590: 73 2d 63 6f 6e 74 65 78 74 2e 70 6f 73 69 78 0a s-context.posix.
05a0: 09 20 20 63 68 69 63 6b 65 6e 2e 70 72 6f 63 65 . chicken.proce
05b0: 73 73 0a 09 20 20 63 68 69 63 6b 65 6e 2e 73 6f ss.. chicken.so
05c0: 72 74 0a 09 20 20 63 68 69 63 6b 65 6e 2e 73 74 rt.. chicken.st
05d0: 72 69 6e 67 0a 09 20 20 63 68 69 63 6b 65 6e 2e ring.. chicken.
05e0: 74 69 6d 65 0a 09 20 20 63 68 69 63 6b 65 6e 2e time.. chicken.
05f0: 74 63 70 0a 09 20 20 63 68 69 63 6b 65 6e 2e 72 tcp.. chicken.r
0600: 61 6e 64 6f 6d 0a 09 20 20 63 68 69 63 6b 65 6e andom.. chicken
0610: 2e 66 69 6c 65 2e 70 6f 73 69 78 0a 09 20 20 63 .file.posix.. c
0620: 68 69 63 6b 65 6e 2e 70 72 65 74 74 79 2d 70 72 hicken.pretty-pr
0630: 69 6e 74 0a 09 20 20 63 68 69 63 6b 65 6e 2e 69 int.. chicken.i
0640: 6f 0a 09 20 20 63 68 69 63 6b 65 6e 2e 70 6f 72 o.. chicken.por
0650: 74 0a 09 20 20 63 68 69 63 6b 65 6e 2e 70 72 6f t.. chicken.pro
0660: 63 65 73 73 2d 63 6f 6e 74 65 78 74 0a 0a 09 20 cess-context...
0670: 20 73 79 73 74 65 6d 2d 69 6e 66 6f 72 6d 61 74 system-informat
0680: 69 6f 6e 29 0a 20 20 28 64 65 66 69 6e 65 20 75 ion). (define u
0690: 6e 73 65 74 65 6e 76 20 75 6e 73 65 74 2d 65 6e nsetenv unset-en
06a0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
06b0: 6c 65 21 29 0a 20 20 29 29 0a 20 0a 20 28 69 6d le!). )). . (im
06c0: 70 6f 72 74 20 20 61 64 64 72 65 73 73 2d 69 6e port address-in
06d0: 66 6f 0a 09 20 20 64 69 72 65 63 74 6f 72 79 2d fo.. directory-
06e0: 75 74 69 6c 73 0a 09 20 20 6d 61 74 63 68 61 62 utils.. matchab
06f0: 6c 65 0a 09 20 20 6d 64 35 0a 09 20 20 6d 65 73 le.. md5.. mes
0700: 73 61 67 65 2d 64 69 67 65 73 74 0a 09 20 20 72 sage-digest.. r
0710: 65 67 65 78 0a 09 20 20 72 65 67 65 78 2d 63 61 egex.. regex-ca
0720: 73 65 0a 09 20 20 73 31 31 6e 0a 09 20 20 73 72 se.. s11n.. sr
0730: 66 69 2d 31 0a 09 20 20 73 72 66 69 2d 31 38 0a fi-1.. srfi-18.
0740: 09 20 20 73 72 66 69 2d 34 0a 09 20 20 73 72 66 . srfi-4.. srf
0750: 69 2d 36 39 0a 09 20 20 73 74 61 63 6b 0a 09 20 i-69.. stack..
0760: 20 74 79 70 65 64 2d 72 65 63 6f 72 64 73 0a 09 typed-records..
0770: 20 20 74 63 70 2d 73 65 72 76 65 72 0a 09 20 20 tcp-server..
0780: 0a 09 20 20 64 65 62 75 67 70 72 69 6e 74 0a 09 .. debugprint..
0790: 20 20 63 6f 6d 6d 6f 6e 6d 6f 64 0a 09 20 20 64 commonmod.. d
07a0: 62 66 69 6c 65 0a 09 20 20 64 62 6d 6f 64 0a 09 bfile.. dbmod..
07b0: 20 20 6d 74 6d 6f 64 0a 09 20 20 70 6f 72 74 6c mtmod.. portl
07c0: 6f 67 67 65 72 0a 09 29 0a 0a 3b 3b 3d 3d 3d 3d ogger..)..;;====
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0810: 3d 3d 0a 3b 3b 20 63 6c 69 65 6e 74 0a 3b 3b 3d ==.;; client.;;=
0820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0860: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 64 65 66 69 6e =====..;; (defin
0870: 65 20 6b 65 65 70 2d 61 67 65 2d 70 61 72 61 6d e keep-age-param
0880: 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 (make-parameter
0890: 20 31 30 29 29 20 3b 3b 20 71 69 66 20 66 69 6c 10)) ;; qif fil
08a0: 65 20 61 67 65 2c 20 69 66 20 6f 76 65 72 20 6d e age, if over m
08b0: 6f 76 65 20 74 6f 20 61 74 74 69 63 0a 0a 3b 3b ove to attic..;;
08c0: 20 55 73 65 64 20 4f 4e 4c 59 20 66 6f 72 20 63 Used ONLY for c
08d0: 6c 69 65 6e 74 0a 3b 3b 0a 28 64 65 66 73 74 72 lient.;;.(defstr
08e0: 75 63 74 20 74 74 2d 63 6f 6e 6e 0a 20 20 68 6f uct tt-conn. ho
08f0: 73 74 0a 20 20 70 6f 72 74 0a 20 20 68 6f 73 74 st. port. host
0900: 2d 70 6f 72 74 0a 20 20 64 62 66 6e 61 6d 65 0a -port. dbfname.
0910: 20 20 73 65 72 76 65 72 2d 69 64 0a 20 20 73 65 server-id. se
0920: 72 76 65 72 2d 73 74 61 72 74 0a 20 20 73 65 72 rver-start. ser
0930: 76 69 6e 66 2d 66 69 6c 65 0a 20 20 70 69 64 0a vinf-file. pid.
0940: 29 0a 0a 3b 3b 20 55 73 65 64 20 66 6f 72 20 42 )..;; Used for B
0950: 4f 54 48 20 63 6c 69 65 6e 74 73 20 61 6e 64 20 OTH clients and
0960: 73 65 72 76 65 72 73 0a 28 64 65 66 73 74 72 75 servers.(defstru
0970: 63 74 20 74 74 0a 20 20 3b 3b 20 63 6c 69 65 6e ct tt. ;; clien
0980: 74 20 72 65 6c 61 74 65 64 0a 20 20 28 63 6f 6e t related. (con
0990: 6e 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 ns (make-hash-ta
09a0: 62 6c 65 29 29 20 3b 3b 20 64 62 66 6e 61 6d 65 ble)) ;; dbfname
09b0: 20 2d 3e 20 63 6f 6e 6e 0a 0a 20 20 3b 3b 20 73 -> conn.. ;; s
09c0: 65 72 76 65 72 20 72 65 6c 61 74 65 64 0a 20 20 erver related.
09d0: 28 73 74 61 74 65 20 20 20 20 20 20 20 20 27 73 (state 's
09e0: 74 61 72 74 69 6e 67 29 0a 20 20 28 61 72 65 61 tarting). (area
09f0: 70 61 74 68 20 20 20 20 20 23 66 29 0a 20 20 28 path #f). (
0a00: 68 6f 73 74 20 20 20 20 20 20 20 20 20 23 66 29 host #f)
0a10: 0a 20 20 28 70 6f 72 74 20 20 20 20 20 20 20 20 . (port
0a20: 20 23 66 29 0a 20 20 28 63 6f 6e 6e 20 20 20 20 #f). (conn
0a30: 20 20 20 20 20 23 66 29 0a 20 20 28 63 6c 65 61 #f). (clea
0a40: 6e 75 70 2d 70 72 6f 63 20 23 66 29 0a 20 20 28 nup-proc #f). (
0a50: 68 61 6e 64 6c 65 72 20 20 20 20 20 20 23 66 29 handler #f)
0a60: 20 3b 3b 20 72 65 63 65 69 76 65 73 20 64 61 74 ;; receives dat
0a70: 61 20 61 6e 64 20 72 65 73 70 6f 6e 64 73 0a 20 a and responds.
0a80: 20 28 73 6f 63 6b 65 74 20 20 20 20 20 20 20 23 (socket #
0a90: 66 29 0a 20 20 28 74 68 72 65 61 64 20 20 20 20 f). (thread
0aa0: 20 20 20 23 66 29 0a 20 20 28 68 6f 73 74 2d 70 #f). (host-p
0ab0: 6f 72 74 20 20 20 20 23 66 29 0a 20 20 28 63 6d ort #f). (cm
0ac0: 64 2d 74 68 72 65 61 64 20 20 20 23 66 29 0a 20 d-thread #f).
0ad0: 20 28 72 6f 2d 6d 6f 64 65 20 20 20 20 20 20 23 (ro-mode #
0ae0: 66 29 0a 20 20 28 72 6f 2d 6d 6f 64 65 2d 63 68 f). (ro-mode-ch
0af0: 65 63 6b 65 64 20 23 66 29 0a 20 20 28 6c 61 73 ecked #f). (las
0b00: 74 2d 61 63 63 65 73 73 20 20 28 63 75 72 72 65 t-access (curre
0b10: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 28 nt-seconds)). (
0b20: 73 65 72 76 69 6e 66 2d 66 69 6c 65 20 23 66 29 servinf-file #f)
0b30: 0a 20 20 28 6c 61 73 74 2d 73 65 72 76 2d 73 74 . (last-serv-st
0b40: 61 72 74 20 30 29 0a 20 20 29 0a 0a 3b 3b 20 70 art 0). )..;; p
0b50: 61 72 61 6d 65 74 65 72 73 0a 3b 3b 0a 28 64 65 arameters.;;.(de
0b60: 66 69 6e 65 20 74 74 2d 73 65 72 76 65 72 2d 74 fine tt-server-t
0b70: 69 6d 65 6f 75 74 2d 70 61 72 61 6d 20 28 6d 61 imeout-param (ma
0b80: 6b 65 2d 70 61 72 61 6d 65 74 65 72 20 36 30 30 ke-parameter 600
0b90: 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 74 74 64 61 ))..;; make ttda
0ba0: 74 20 76 69 73 69 62 6c 65 0a 3b 3b 20 28 64 65 t visible.;; (de
0bb0: 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 6e 66 fine *server-inf
0bc0: 6f 2a 20 23 66 29 20 3b 3b 20 67 65 74 20 74 68 o* #f) ;; get th
0bd0: 69 73 20 66 72 6f 6d 20 63 6f 6d 6d 6f 6e 6d 6f is from commonmo
0be0: 64 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 76 65 d.(define *serve
0bf0: 72 2d 72 75 6e 2a 20 20 23 74 29 0a 0a 28 64 65 r-run* #t)..(de
0c00: 66 69 6e 65 20 28 74 74 3a 6d 61 6b 65 2d 72 65 fine (tt:make-re
0c10: 6d 6f 74 65 20 61 72 65 61 70 61 74 68 29 0a 20 mote areapath).
0c20: 20 28 6d 61 6b 65 2d 74 74 20 61 72 65 61 70 61 (make-tt areapa
0c30: 74 68 3a 20 61 72 65 61 70 61 74 68 29 29 0a 0a th: areapath))..
0c40: 3b 3b 20 31 20 2e 2e 2e 20 6f 72 20 23 66 0a 3b ;; 1 ... or #f.;
0c50: 3b 20 61 6e 64 20 63 68 65 63 6b 20 74 68 61 74 ; and check that
0c60: 20 64 62 66 6e 61 6d 65 20 6d 61 74 63 68 65 73 dbfname matches
0c70: 2e 20 46 49 58 4d 45 3a 20 74 68 65 20 70 72 6f . FIXME: the pro
0c80: 70 61 67 61 74 69 6f 6e 20 6f 66 20 64 62 66 6e pagation of dbfn
0c90: 61 6d 65 20 61 6e 64 20 72 75 6e 2d 69 64 0a 3b ame and run-id.;
0ca0: 3b 20 6d 69 67 68 74 20 6e 6f 74 20 6d 61 6b 65 ; might not make
0cb0: 20 74 68 65 20 62 65 73 74 20 73 65 6e 73 65 0a the best sense.
0cc0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 76 ;;.(define (tt:v
0cd0: 61 6c 69 64 2d 72 75 6e 2d 69 64 20 72 75 6e 2d alid-run-id run-
0ce0: 69 64 20 64 62 66 6e 61 6d 65 29 0a 20 20 28 61 id dbfname). (a
0cf0: 6e 64 20 28 6f 72 20 28 6e 75 6d 62 65 72 3f 20 nd (or (number?
0d00: 72 75 6e 2d 69 64 29 0a 09 20 20 20 28 6e 6f 74 run-id).. (not
0d10: 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 20 20 run-id)).
0d20: 20 28 65 71 75 61 6c 3f 20 28 64 62 66 69 6c 65 (equal? (dbfile
0d30: 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 6e 61 6d 65 :run-id->dbfname
0d40: 20 72 75 6e 2d 69 64 29 20 64 62 66 6e 61 6d 65 run-id) dbfname
0d50: 29 29 29 0a 0a 28 74 63 70 2d 62 75 66 66 65 72 )))..(tcp-buffer
0d60: 2d 73 69 7a 65 20 32 30 34 38 29 0a 3b 3b 20 28 -size 2048).;; (
0d70: 6d 61 78 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 max-connections
0d80: 34 30 39 36 29 0a 0a 28 64 65 66 69 6e 65 20 28 4096)..(define (
0d90: 74 74 3a 67 65 74 2d 63 6f 6e 6e 20 74 74 64 61 tt:get-conn ttda
0da0: 74 20 64 62 66 6e 61 6d 65 29 0a 20 20 28 68 61 t dbfname). (ha
0db0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0dc0: 61 75 6c 74 20 28 74 74 2d 63 6f 6e 6e 73 20 74 ault (tt-conns t
0dd0: 74 64 61 74 29 20 64 62 66 6e 61 6d 65 20 23 66 tdat) dbfname #f
0de0: 29 29 0a 0a 3b 3b 20 64 6f 20 61 6c 6c 20 74 68 ))..;; do all th
0df0: 65 20 62 75 73 79 20 77 6f 72 6b 20 6f 66 20 66 e busy work of f
0e00: 69 6e 64 69 6e 67 20 61 6e 64 20 73 65 74 74 69 inding and setti
0e10: 6e 67 20 75 70 20 63 6f 6e 6e 20 66 6f 72 0a 3b ng up conn for.;
0e20: 3b 20 63 6f 6e 6e 65 63 74 69 6e 67 20 74 6f 20 ; connecting to
0e30: 61 20 73 65 72 76 65 72 0a 3b 3b 20 0a 28 64 65 a server.;; .(de
0e40: 66 69 6e 65 20 28 74 74 3a 63 6c 69 65 6e 74 2d fine (tt:client-
0e50: 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 65 connect-to-serve
0e60: 72 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 20 r ttdat dbfname
0e70: 72 75 6e 2d 69 64 20 74 65 73 74 73 75 69 74 65 run-id testsuite
0e80: 20 73 65 72 76 65 72 2d 73 74 61 72 74 2d 70 72 server-start-pr
0e90: 6f 63 29 0a 20 20 28 61 73 73 65 72 74 20 28 74 oc). (assert (t
0ea0: 74 3a 76 61 6c 69 64 2d 72 75 6e 2d 69 64 20 72 t:valid-run-id r
0eb0: 75 6e 2d 69 64 20 64 62 66 6e 61 6d 65 29 20 22 un-id dbfname) "
0ec0: 46 41 54 41 4c 3a 20 69 6e 76 61 6c 69 64 20 72 FATAL: invalid r
0ed0: 75 6e 2d 69 64 20 22 72 75 6e 2d 69 64 29 0a 20 un-id "run-id).
0ee0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
0ef0: 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 2 *default-lo
0f00: 67 2d 70 6f 72 74 2a 20 22 74 74 3a 63 6c 69 65 g-port* "tt:clie
0f10: 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 nt-connect-to-se
0f20: 72 76 65 72 20 22 20 64 62 66 6e 61 6d 65 20 22 rver " dbfname "
0f30: 20 22 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 " run-id). (le
0f40: 74 2a 20 28 28 63 6f 6e 6e 20 20 20 20 20 20 20 t* ((conn
0f50: 20 20 20 20 20 20 20 28 74 74 3a 67 65 74 2d 63 (tt:get-c
0f60: 6f 6e 6e 20 74 74 64 61 74 20 64 62 66 6e 61 6d onn ttdat dbfnam
0f70: 65 29 29 0a 09 20 28 73 65 72 76 65 72 2d 73 74 e)).. (server-st
0f80: 61 72 74 2d 70 72 6f 63 20 28 6f 72 20 73 65 72 art-proc (or ser
0f90: 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 0a 09 ver-start-proc..
0fa0: 09 09 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ...(lambda ()...
0fb0: 09 09 20 20 28 61 73 73 65 72 74 20 28 65 71 75 .. (assert (equ
0fc0: 61 6c 3f 20 64 62 66 6e 61 6d 65 20 22 6d 61 69 al? dbfname "mai
0fd0: 6e 2e 64 62 22 29 20 3b 3b 20 6f 6e 6c 79 20 6d n.db") ;; only m
0fe0: 61 69 6e 2e 64 62 20 69 73 20 73 74 61 72 74 65 ain.db is starte
0ff0: 64 20 68 65 72 65 0a 09 09 09 09 09 20 20 22 46 d here...... "F
1000: 41 54 41 4c 3a 20 63 61 6c 6c 65 64 20 73 65 72 ATAL: called ser
1010: 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 20 66 ver-start-proc f
1020: 6f 72 20 64 62 20 6f 74 68 65 72 20 74 68 61 6e or db other than
1030: 20 6d 61 69 6e 2e 64 62 22 29 0a 09 09 09 09 20 main.db").....
1040: 20 28 74 74 3a 73 65 72 76 65 72 2d 70 72 6f 63 (tt:server-proc
1050: 65 73 73 2d 72 75 6e 0a 09 09 09 09 20 20 20 28 ess-run..... (
1060: 74 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 61 tt-areapath ttda
1070: 74 29 0a 09 09 09 09 20 20 20 74 65 73 74 73 75 t)..... testsu
1080: 69 74 65 20 3b 3b 20 28 64 62 66 69 6c 65 3a 74 ite ;; (dbfile:t
1090: 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a 09 estsuite-name)..
10a0: 09 09 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 ... (common:fi
10b0: 6e 64 2d 6c 6f 63 61 6c 2d 6d 65 67 61 74 65 73 nd-local-megates
10c0: 74 29 0a 09 09 09 09 20 20 20 72 75 6e 2d 69 64 t)..... run-id
10d0: 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 63 6f ))))). (if co
10e0: 6e 6e 0a 09 28 62 65 67 69 6e 20 0a 20 20 20 20 nn..(begin .
10f0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1100: 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 nt-info 2 *defau
1110: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 6c lt-log-port* "al
1120: 72 65 61 64 79 20 63 6f 6e 6e 65 63 74 65 64 20 ready connected
1130: 74 6f 20 61 20 73 65 72 76 65 72 22 29 0a 20 20 to a server").
1140: 20 20 20 20 20 20 20 20 20 63 6f 6e 6e 29 20 3b conn) ;
1150: 3b 20 77 65 20 61 72 65 20 61 6c 72 65 61 64 79 ; we are already
1160: 20 63 6f 6e 6e 65 63 74 65 64 20 74 6f 20 74 68 connected to th
1170: 65 20 73 65 72 76 65 72 0a 0a 09 3b 3b 20 6e 6f e server...;; no
1180: 20 63 6f 6e 6e 0a 20 20 20 20 20 20 20 20 28 6c conn. (l
1190: 65 74 2a 20 28 28 73 64 61 74 73 20 28 74 74 3a et* ((sdats (tt:
11a0: 67 65 74 2d 73 65 72 76 65 72 2d 69 6e 66 6f 2d get-server-info-
11b0: 73 6f 72 74 65 64 20 74 74 64 61 74 20 64 62 66 sorted ttdat dbf
11c0: 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 name)).. (
11d0: 73 64 61 74 20 20 28 69 66 20 28 6e 75 6c 6c 3f sdat (if (null?
11e0: 20 73 64 61 74 73 29 0a 09 09 09 20 20 23 66 0a sdats).... #f.
11f0: 09 09 09 20 20 28 63 61 72 20 73 64 61 74 73 29 ... (car sdats)
1200: 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 ))).. (debug:p
1210: 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 rint-info 2 *def
1220: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1230: 66 6f 75 6e 64 20 73 64 61 74 20 22 20 73 64 61 found sdat " sda
1240: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d t). (m
1250: 61 74 63 68 20 73 64 61 74 0a 09 20 20 20 20 28 atch sdat.. (
1260: 28 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 (host port start
1270: 2d 74 69 6d 65 20 73 65 72 76 65 72 2d 69 64 20 -time server-id
1280: 70 69 64 20 64 62 66 6e 61 6d 65 32 20 73 65 72 pid dbfname2 ser
1290: 76 69 6e 66 66 69 6c 65 29 0a 09 20 20 20 20 20 vinffile)..
12a0: 28 61 73 73 65 72 74 20 28 65 71 75 61 6c 3f 20 (assert (equal?
12b0: 64 62 66 6e 61 6d 65 20 64 62 66 6e 61 6d 65 32 dbfname dbfname2
12c0: 29 20 22 46 41 54 41 4c 3a 20 72 65 61 64 20 73 ) "FATAL: read s
12d0: 65 72 76 65 72 20 69 6e 66 6f 20 66 72 6f 6d 20 erver info from
12e0: 77 72 6f 6e 67 20 66 69 6c 65 2e 22 29 0a 20 20 wrong file.").
12f0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
1300: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a g:print-info 2 *
1310: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1320: 2a 20 22 6e 6f 20 63 6f 6e 6e 20 2d 20 69 6e 20 * "no conn - in
1330: 6d 61 74 63 68 20 73 65 72 76 69 6e 66 66 69 6c match servinffil
1340: 65 3a 22 20 73 65 72 76 69 6e 66 66 69 6c 65 29 e:" servinffile)
1350: 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 68 .. (let* ((h
1360: 6f 73 74 2d 70 6f 72 74 20 28 63 6f 6e 63 20 68 ost-port (conc h
1370: 6f 73 74 22 3a 22 70 6f 72 74 29 29 0a 09 09 20 ost":"port))...
1380: 20 20 20 28 63 6f 6e 6e 20 28 6d 61 6b 65 2d 74 (conn (make-t
1390: 74 2d 63 6f 6e 6e 0a 09 09 09 20 20 20 68 6f 73 t-conn.... hos
13a0: 74 3a 20 68 6f 73 74 0a 09 09 09 20 20 20 70 6f t: host.... po
13b0: 72 74 3a 20 70 6f 72 74 0a 09 09 09 20 20 20 68 rt: port.... h
13c0: 6f 73 74 2d 70 6f 72 74 3a 20 68 6f 73 74 2d 70 ost-port: host-p
13d0: 6f 72 74 0a 09 09 09 20 20 20 64 62 66 6e 61 6d ort.... dbfnam
13e0: 65 3a 20 64 62 66 6e 61 6d 65 0a 09 09 09 20 20 e: dbfname....
13f0: 20 73 65 72 76 69 6e 66 2d 66 69 6c 65 3a 20 73 servinf-file: s
1400: 65 72 76 69 6e 66 66 69 6c 65 0a 09 09 09 20 20 ervinffile....
1410: 20 73 65 72 76 65 72 2d 69 64 3a 20 73 65 72 76 server-id: serv
1420: 65 72 2d 69 64 0a 09 09 09 20 20 20 73 65 72 76 er-id.... serv
1430: 65 72 2d 73 74 61 72 74 3a 20 73 74 61 72 74 2d er-start: start-
1440: 74 69 6d 65 0a 09 09 09 20 20 20 70 69 64 3a 20 time.... pid:
1450: 70 69 64 29 29 29 0a 09 20 20 20 20 20 20 20 3b pid))).. ;
1460: 3b 20 76 65 72 69 66 79 20 77 65 20 63 61 6e 20 ; verify we can
1470: 74 61 6c 6b 20 74 6f 20 74 68 69 73 20 73 65 72 talk to this ser
1480: 76 65 72 0a 09 20 20 20 20 20 20 20 28 6c 65 74 ver.. (let
1490: 2a 20 28 28 72 65 73 75 6c 74 20 20 20 28 74 74 * ((result (tt
14a0: 3a 74 69 6d 65 64 2d 70 69 6e 67 20 68 6f 73 74 :timed-ping host
14b0: 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 29 port server-id)
14c0: 29 0a 09 09 20 20 20 20 20 20 28 70 69 6e 67 2d )... (ping-
14d0: 72 65 73 20 28 63 61 72 20 72 65 73 75 6c 74 29 res (car result)
14e0: 29 0a 09 09 20 20 20 20 20 20 28 70 69 6e 67 20 )... (ping
14f0: 20 20 20 20 28 63 64 72 20 72 65 73 75 6c 74 29 (cdr result)
1500: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
1510: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1520: 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 -info 2 *default
1530: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 68 6f 73 74 -log-port* "host
1540: 20 22 20 68 6f 73 74 20 22 20 70 6f 72 74 20 22 " host " port "
1550: 20 70 6f 72 74 20 22 20 70 69 6e 67 20 74 69 6d port " ping tim
1560: 65 3a 20 22 20 70 69 6e 67 20 22 20 72 65 73 75 e: " ping " resu
1570: 6c 74 20 22 20 70 69 6e 67 2d 72 65 73 29 0a 09 lt " ping-res)..
1580: 09 20 28 63 61 73 65 20 70 69 6e 67 2d 72 65 73 . (case ping-res
1590: 0a 09 09 20 20 20 28 28 72 75 6e 6e 69 6e 67 29 ... ((running)
15a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
15b0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
15c0: 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
15d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 74 t-log-port* "Set
15e0: 74 69 6e 67 20 63 6f 6e 6e 20 3d 20 22 20 63 6f ting conn = " co
15f0: 6e 6e 20 22 20 69 6e 20 68 61 73 68 20 74 61 62 nn " in hash tab
1600: 6c 65 22 29 0a 09 09 20 20 20 20 28 68 61 73 68 le")... (hash
1610: 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 74 74 2d -table-set! (tt-
1620: 63 6f 6e 6e 73 20 74 74 64 61 74 29 20 64 62 66 conns ttdat) dbf
1630: 6e 61 6d 65 20 63 6f 6e 6e 29 20 3b 3b 3b 20 69 name conn) ;;; i
1640: 73 20 74 68 69 73 20 6f 6b 20 74 6f 20 73 61 76 s this ok to sav
1650: 65 20 62 65 66 6f 72 65 20 76 61 6c 69 64 61 74 e before validat
1660: 69 6e 67 20 74 68 61 74 20 74 68 65 20 63 6f 6e ing that the con
1670: 6e 65 63 74 69 6f 6e 20 69 73 20 67 6f 6f 64 3f nection is good?
1680: 0a 09 09 20 20 20 20 63 6f 6e 6e 29 0a 09 09 20 ... conn)...
1690: 20 20 28 28 73 74 61 72 74 69 6e 67 29 0a 09 09 ((starting)...
16a0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
16b0: 70 21 20 30 2e 35 29 0a 20 20 20 20 20 20 20 20 p! 0.5).
16c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
16d0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
16e0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
16f0: 74 2a 20 22 73 65 72 76 65 72 20 66 6f 72 20 22 t* "server for "
1700: 20 64 62 66 6e 61 6d 65 20 22 20 69 73 20 69 6e dbfname " is in
1710: 20 73 74 61 72 74 69 6e 67 20 73 74 61 74 65 2c starting state,
1720: 20 72 65 74 72 79 69 6e 67 20 63 6f 6e 6e 65 63 retrying connec
1730: 74 22 29 0a 09 09 20 20 20 20 28 74 74 3a 63 6c t")... (tt:cl
1740: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d ient-connect-to-
1750: 73 65 72 76 65 72 20 74 74 64 61 74 20 64 62 66 server ttdat dbf
1760: 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 name run-id test
1770: 73 75 69 74 65 20 73 65 72 76 65 72 2d 73 74 61 suite server-sta
1780: 72 74 2d 70 72 6f 63 29 29 0a 09 09 20 20 20 28 rt-proc))... (
1790: 65 6c 73 65 0a 09 09 20 20 20 20 28 6c 65 74 2a else... (let*
17a0: 20 28 28 63 75 72 72 2d 73 65 63 73 20 28 63 75 ((curr-secs (cu
17b0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
17c0: 0a 09 09 20 20 20 20 20 20 3b 3b 20 72 6d 20 74 ... ;; rm t
17d0: 68 65 20 28 6c 61 73 74 20 73 65 72 76 65 72 29 he (last server)
17e0: 20 77 6f 75 6c 64 20 67 6f 20 68 65 72 65 0a 09 would go here..
17f0: 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 2d . (if (> (-
1800: 20 63 75 72 72 2d 73 65 63 73 20 28 74 74 2d 6c curr-secs (tt-l
1810: 61 73 74 2d 73 65 72 76 2d 73 74 61 72 74 20 74 ast-serv-start t
1820: 74 64 61 74 29 29 20 31 30 29 0a 09 09 09 20 20 tdat)) 10)....
1830: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 28 64 (begin.... (d
1840: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1850: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1860: 6f 72 74 2a 20 22 55 6e 72 65 61 63 68 61 62 6c ort* "Unreachabl
1870: 65 20 73 65 72 76 65 72 20 61 74 20 22 0a 09 09 e server at "...
1880: 09 09 09 20 20 20 20 20 20 68 6f 73 74 22 3a 22 ... host":"
1890: 70 6f 72 74 22 20 77 69 74 68 20 73 65 72 76 69 port" with servi
18a0: 6e 66 6f 20 66 69 6c 65 20 22 73 65 72 76 69 6e nfo file "servin
18b0: 66 66 69 6c 65 22 2c 20 72 65 6d 6f 76 69 6e 67 ffile", removing
18c0: 20 69 74 22 29 0a 09 09 09 20 20 20 20 28 69 66 it").... (if
18d0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 (file-exists? s
18e0: 65 72 76 69 6e 66 66 69 6c 65 29 0a 09 09 09 09 ervinffile).....
18f0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
1900: 6e 73 0a 09 09 09 09 20 65 78 6e 0a 09 09 09 09 ns..... exn.....
1910: 20 23 66 0a 09 09 09 09 20 28 64 65 6c 65 74 65 #f..... (delete
1920: 2d 66 69 6c 65 20 73 65 72 76 69 6e 66 66 69 6c -file servinffil
1930: 65 29 29 29 0a 09 09 09 20 20 20 20 28 74 74 2d e))).... (tt-
1940: 6c 61 73 74 2d 73 65 72 76 2d 73 74 61 72 74 2d last-serv-start-
1950: 73 65 74 21 20 74 74 64 61 74 20 63 75 72 72 2d set! ttdat curr-
1960: 73 65 63 73 29 0a 20 20 20 20 20 20 20 20 20 20 secs).
1970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1980: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
1990: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
19a0: 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 72 74 69 og-port* "Starti
19b0: 6e 67 20 61 20 6e 65 77 20 73 65 72 76 65 72 20 ng a new server
19c0: 6f 6e 20 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e on " (get-host-n
19d0: 61 6d 65 29 29 0a 09 09 09 20 20 20 20 28 73 65 ame)).... (se
19e0: 72 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 29 rver-start-proc)
19f0: 29 29 20 3b 3b 20 73 74 61 72 74 20 73 65 72 76 )) ;; start serv
1a00: 65 72 20 69 66 20 31 30 20 73 65 63 20 73 69 6e er if 10 sec sin
1a10: 63 65 20 6c 61 73 74 20 61 74 74 65 6d 70 74 0a ce last attempt.
1a20: 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
1a30: 73 6c 65 65 70 21 20 31 29 0a 20 20 20 20 20 20 sleep! 1).
1a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a50: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1a60: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
1a70: 2d 70 6f 72 74 2a 20 22 52 65 74 72 79 69 6e 67 -port* "Retrying
1a80: 20 63 6f 6e 6e 65 63 74 22 29 0a 09 09 20 20 20 connect")...
1a90: 20 20 20 28 74 74 3a 63 6c 69 65 6e 74 2d 63 6f (tt:client-co
1aa0: 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 65 72 20 nnect-to-server
1ab0: 74 74 64 61 74 20 64 62 66 6e 61 6d 65 20 72 75 ttdat dbfname ru
1ac0: 6e 2d 69 64 20 74 65 73 74 73 75 69 74 65 20 73 n-id testsuite s
1ad0: 65 72 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 erver-start-proc
1ae0: 29 29 29 29 29 29 29 0a 0a 09 20 20 20 20 28 65 )))))))... (e
1af0: 6c 73 65 20 3b 3b 20 6e 6f 20 67 6f 6f 64 20 73 lse ;; no good s
1b00: 65 72 76 65 72 20 66 6f 75 6e 64 2c 20 69 66 20 erver found, if
1b10: 68 61 76 65 6e 27 74 20 73 74 61 72 74 65 64 20 haven't started
1b20: 73 65 72 76 65 72 20 69 6e 20 3e 20 35 20 73 65 server in > 5 se
1b30: 63 73 2c 20 73 74 61 72 74 20 61 6e 6f 74 68 65 cs, start anothe
1b40: 72 0a 09 20 20 20 20 20 28 69 66 20 28 3e 20 28 r.. (if (> (
1b50: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
1b60: 64 73 29 20 28 74 74 2d 6c 61 73 74 2d 73 65 72 ds) (tt-last-ser
1b70: 76 2d 73 74 61 72 74 20 74 74 64 61 74 29 29 20 v-start ttdat))
1b80: 33 29 20 3b 3b 20 42 55 47 20 2d 20 67 72 6f 77 3) ;; BUG - grow
1b90: 20 74 68 69 73 20 6e 75 6d 62 65 72 20 72 65 61 this number rea
1ba0: 6c 6c 79 20 64 6f 20 6e 6f 74 20 77 61 6e 74 20 lly do not want
1bb0: 74 6f 20 73 77 61 6d 70 20 74 68 65 20 6d 61 63 to swamp the mac
1bc0: 68 69 6e 65 20 77 69 74 68 20 73 65 72 76 65 72 hine with server
1bd0: 73 0a 09 09 20 28 62 65 67 69 6e 0a 09 09 20 20 s... (begin...
1be0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
1bf0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
1c00: 67 2d 70 6f 72 74 2a 20 22 53 74 61 72 74 69 6e g-port* "Startin
1c10: 67 20 73 65 72 76 65 72 20 66 6f 72 20 22 64 62 g server for "db
1c20: 66 6e 61 6d 65 20 22 20 6f 6e 20 22 20 28 67 65 fname " on " (ge
1c30: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 09 t-host-name))...
1c40: 20 20 20 28 73 65 72 76 65 72 2d 73 74 61 72 74 (server-start
1c50: 2d 70 72 6f 63 29 0a 09 09 20 20 20 28 74 74 2d -proc)... (tt-
1c60: 6c 61 73 74 2d 73 65 72 76 2d 73 74 61 72 74 2d last-serv-start-
1c70: 73 65 74 21 20 74 74 64 61 74 20 28 63 75 72 72 set! ttdat (curr
1c80: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 ent-seconds)).
1c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ca0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
1cb0: 36 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 6).
1cc0: 20 20 20 20 20 20 29 29 0a 09 20 20 20 20 20 28 )).. (
1cd0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
1ce0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 . (d
1cf0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1d00: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1d10: 6f 72 74 2a 20 22 43 6f 6e 6e 65 63 74 20 74 6f ort* "Connect to
1d20: 20 73 65 72 76 65 72 20 66 72 6f 6d 20 22 20 28 server from " (
1d30: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 get-host-name) "
1d40: 20 66 6f 72 20 22 20 64 62 66 6e 61 6d 65 29 0a for " dbfname).
1d50: 09 20 20 20 20 20 28 74 74 3a 63 6c 69 65 6e 74 . (tt:client
1d60: 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 -connect-to-serv
1d70: 65 72 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 er ttdat dbfname
1d80: 20 72 75 6e 2d 69 64 20 74 65 73 74 73 75 69 74 run-id testsuit
1d90: 65 20 73 65 72 76 65 72 2d 73 74 61 72 74 2d 70 e server-start-p
1da0: 72 6f 63 29 29 29 29 29 29 29 0a 0a 3b 3b 20 72 roc)))))))..;; r
1db0: 65 74 75 72 6e 73 20 28 20 72 65 73 75 6c 74 20 eturns ( result
1dc0: 2e 20 70 69 6e 67 5f 74 69 6d 65 20 29 0a 28 64 . ping_time ).(d
1dd0: 65 66 69 6e 65 20 28 74 74 3a 74 69 6d 65 64 2d efine (tt:timed-
1de0: 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 73 ping host port s
1df0: 65 72 76 65 72 2d 69 64 29 0a 20 20 28 6c 65 74 erver-id). (let
1e00: 2a 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 * ((start-time (
1e10: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
1e20: 6f 6e 64 73 29 29 0a 09 20 28 72 65 73 75 6c 74 onds)).. (result
1e30: 20 20 20 20 20 28 74 74 3a 70 69 6e 67 20 68 6f (tt:ping ho
1e40: 73 74 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 st port server-i
1e50: 64 29 29 29 0a 20 20 20 20 28 63 6f 6e 73 20 72 d))). (cons r
1e60: 65 73 75 6c 74 20 28 2d 20 28 63 75 72 72 65 6e esult (- (curren
1e70: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 t-milliseconds)
1e80: 73 74 61 72 74 2d 74 69 6d 65 29 29 29 29 0a 20 start-time)))).
1e90: 20 20 20 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 ..(define (tt
1ea0: 3a 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 :ping host port
1eb0: 73 65 72 76 65 72 2d 69 64 20 23 21 6f 70 74 69 server-id #!opti
1ec0: 6f 6e 61 6c 20 28 74 72 69 65 73 2d 6c 65 66 74 onal (tries-left
1ed0: 20 35 29 29 0a 20 20 28 6c 65 74 2a 20 20 28 28 5)). (let* ((
1ee0: 72 65 73 20 20 20 20 20 20 28 74 74 3a 73 65 6e res (tt:sen
1ef0: 64 2d 72 65 63 65 69 76 65 2d 64 69 72 65 63 74 d-receive-direct
1f00: 20 68 6f 73 74 20 70 6f 72 74 20 60 28 70 69 6e host port `(pin
1f10: 67 20 23 66 20 23 66 20 23 66 29 20 70 69 6e 67 g #f #f #f) ping
1f20: 2d 6d 6f 64 65 3a 20 23 74 29 29 20 3b 3b 20 70 -mode: #t)) ;; p
1f30: 6c 65 61 73 65 20 73 65 6e 64 20 6d 65 20 79 6f lease send me yo
1f40: 75 72 20 73 65 72 76 65 72 2d 69 64 0a 09 20 20 ur server-id..
1f50: 28 74 72 79 2d 61 67 61 69 6e 20 28 6c 61 6d 62 (try-again (lamb
1f60: 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 da ()... (
1f70: 69 66 20 28 3e 20 74 72 69 65 73 2d 6c 65 66 74 if (> tries-left
1f80: 20 30 29 0a 09 09 09 20 20 20 28 62 65 67 69 6e 0).... (begin
1f90: 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 .... (thread
1fa0: 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 09 20 20 -sleep! 1)....
1fb0: 20 20 20 28 74 74 3a 70 69 6e 67 20 68 6f 73 74 (tt:ping host
1fc0: 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 20 port server-id
1fd0: 28 2d 20 74 72 69 65 73 2d 6c 65 66 74 20 31 29 (- tries-left 1)
1fe0: 29 29 0a 09 09 09 20 20 20 23 66 29 29 29 29 0a )).... #f)))).
1ff0: 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 6e 65 ;;. ;; ne
2000: 65 64 20 74 77 6f 20 74 68 72 65 61 64 73 2c 20 ed two threads,
2010: 6f 6e 65 20 61 20 35 20 73 65 63 6f 6e 64 20 74 one a 5 second t
2020: 69 6d 65 72 0a 20 20 20 20 3b 3b 0a 20 20 20 20 imer. ;;.
2030: 28 6d 61 74 63 68 20 72 65 73 0a 20 20 20 20 20 (match res.
2040: 20 28 28 73 74 61 74 75 73 20 65 72 72 6d 73 67 ((status errmsg
2050: 20 72 65 73 75 6c 74 20 6d 65 74 61 29 0a 20 20 result meta).
2060: 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f (if (equal?
2070: 20 72 65 73 75 6c 74 20 73 65 72 76 65 72 2d 69 result server-i
2080: 64 29 0a 09 20 20 20 28 6c 65 74 2a 20 28 28 73 d).. (let* ((s
2090: 65 72 76 65 72 2d 73 74 61 74 65 20 28 61 6c 69 erver-state (ali
20a0: 73 74 2d 72 65 66 20 27 73 73 74 61 74 65 20 6d st-ref 'sstate m
20b0: 65 74 61 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 eta))).. ;;
20c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
20d0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
20e0: 2a 20 22 50 69 6e 67 20 74 6f 20 22 68 6f 73 74 * "Ping to "host
20f0: 22 3a 22 70 6f 72 74 22 20 73 75 63 63 65 73 73 ":"port" success
2100: 66 75 6c 2e 22 29 0a 09 20 20 20 20 20 28 6f 72 ful.").. (or
2110: 20 73 65 72 76 65 72 2d 73 74 61 74 65 20 27 75 server-state 'u
2120: 6e 6b 29 29 20 3b 3b 20 74 68 65 6e 20 77 65 20 nk)) ;; then we
2130: 61 72 65 20 67 6f 6f 64 0a 09 20 20 20 28 62 65 are good.. (be
2140: 67 69 6e 0a 09 20 20 20 20 20 28 64 65 62 75 67 gin.. (debug
2150: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
2160: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
2170: 4e 49 4e 47 3a 20 73 65 72 76 65 72 2d 69 64 20 NING: server-id
2180: 64 6f 65 73 20 6e 6f 74 20 6d 61 74 63 68 2c 20 does not match,
2190: 65 78 70 65 63 74 65 64 3a 20 22 73 65 72 76 65 expected: "serve
21a0: 72 2d 69 64 22 2c 20 67 6f 74 3a 20 22 72 65 73 r-id", got: "res
21b0: 75 6c 74 29 0a 09 20 20 20 20 20 23 66 29 29 29 ult).. #f)))
21c0: 0a 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 . (else.
21d0: 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
21e0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
21f0: 6f 67 2d 70 6f 72 74 2a 20 22 72 65 73 20 6e 6f og-port* "res no
2200: 74 20 69 6e 20 66 6f 72 6d 20 28 73 74 61 74 75 t in form (statu
2210: 73 20 65 72 72 6d 73 67 20 72 65 73 75 6c 74 20 s errmsg result
2220: 6d 65 74 61 29 2c 20 67 6f 74 3a 20 22 72 65 73 meta), got: "res
2230: 29 0a 20 20 20 20 20 20 20 28 74 72 79 2d 61 67 ). (try-ag
2240: 61 69 6e 29 29 29 29 29 0a 0a 3b 3b 20 63 6c 69 ain)))))..;; cli
2250: 65 6e 74 20 73 69 64 65 20 68 61 6e 64 6c 65 72 ent side handler
2260: 0a 3b 3b 0a 3b 3b 28 74 74 3a 68 61 6e 64 6c 65 .;;.;;(tt:handle
2270: 72 20 23 3c 74 74 3e 20 67 65 74 2d 6b 65 79 73 r #<tt> get-keys
2280: 20 23 66 20 28 29 20 32 20 23 66 20 22 2f 68 6f #f () 2 #f "/ho
2290: 6d 65 2f 6d 61 74 74 2f 64 61 74 61 2f 6d 65 67 me/matt/data/meg
22a0: 61 74 65 73 74 2f 65 78 74 2d 74 65 73 74 73 22 atest/ext-tests"
22b0: 20 23 66 20 22 6d 61 69 6e 2e 64 62 22 20 22 65 #f "main.db" "e
22c0: 78 74 2d 74 65 73 74 73 22 20 22 2f 68 6f 6d 65 xt-tests" "/home
22d0: 2f 6d 61 74 74 2f 64 61 74 61 2f 6d 65 67 61 74 /matt/data/megat
22e0: 65 73 74 2f 62 69 6e 2f 2e 32 32 2e 30 34 2f 2e est/bin/.22.04/.
22f0: 2e 2f 6d 65 67 61 74 65 73 74 22 29 0a 3b 3b 0a ./megatest").;;.
2300: 28 64 65 66 69 6e 65 20 28 74 74 3a 68 61 6e 64 (define (tt:hand
2310: 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 75 ler ttdat cmd ru
2320: 6e 2d 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 n-id params atte
2330: 6d 70 74 6e 75 6d 20 72 65 61 64 6f 6e 6c 79 2d mptnum readonly-
2340: 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 mode dbfname tes
2350: 74 73 75 69 74 65 20 6d 74 65 78 65 20 73 65 72 tsuite mtexe ser
2360: 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 29 0a ver-start-proc).
2370: 20 20 3b 3b 20 63 6f 6e 6e 65 63 74 2d 74 6f 2d ;; connect-to-
2380: 73 65 72 76 65 72 20 77 69 6c 6c 20 73 74 61 72 server will star
2390: 74 20 61 20 73 65 72 76 65 72 20 69 66 20 6e 65 t a server if ne
23a0: 65 64 65 64 2e 0a 20 20 28 6c 65 74 2a 20 28 28 eded.. (let* ((
23b0: 61 72 65 61 70 61 74 68 20 28 74 74 2d 61 72 65 areapath (tt-are
23c0: 61 70 61 74 68 20 74 74 64 61 74 29 29 0a 09 20 apath ttdat))..
23d0: 28 63 6f 6e 6e 20 20 20 20 20 28 74 74 3a 63 6c (conn (tt:cl
23e0: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d ient-connect-to-
23f0: 73 65 72 76 65 72 20 74 74 64 61 74 20 64 62 66 server ttdat dbf
2400: 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 name run-id test
2410: 73 75 69 74 65 20 73 65 72 76 65 72 2d 73 74 61 suite server-sta
2420: 72 74 2d 70 72 6f 63 29 29 29 20 3b 3b 20 6c 6f rt-proc))) ;; lo
2430: 6f 6b 73 20 75 70 20 63 6f 6e 6e 20 6b 65 79 65 oks up conn keye
2440: 64 20 62 79 20 64 62 66 6e 61 6d 65 0a 20 20 20 d by dbfname.
2450: 20 28 69 66 20 63 6f 6e 6e 0a 09 3b 3b 20 68 61 (if conn..;; ha
2460: 76 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 2c 20 63 ve connection, c
2470: 61 6c 6c 20 74 68 65 20 73 65 72 76 65 72 0a 09 all the server..
2480: 28 6c 65 74 2a 20 28 28 72 65 73 20 28 74 74 3a (let* ((res (tt:
2490: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 74 74 64 send-receive ttd
24a0: 61 74 20 63 6f 6e 6e 20 63 6d 64 20 72 75 6e 2d at conn cmd run-
24b0: 69 64 20 70 61 72 61 6d 73 29 29 29 0a 09 20 20 id params)))..
24c0: 3b 3b 20 72 65 73 20 69 73 20 28 73 74 61 74 75 ;; res is (statu
24d0: 73 20 65 72 72 6d 73 67 20 72 65 73 75 6c 74 20 s errmsg result
24e0: 6d 65 74 61 29 0a 09 20 20 28 6d 61 74 63 68 20 meta).. (match
24f0: 72 65 73 0a 09 20 20 20 20 28 28 73 74 61 74 75 res.. ((statu
2500: 73 20 65 72 72 6d 73 67 20 72 65 73 75 6c 74 20 s errmsg result
2510: 6d 65 74 61 29 0a 09 20 20 20 20 20 28 69 66 20 meta).. (if
2520: 28 6c 69 73 74 3f 20 6d 65 74 61 29 0a 09 09 20 (list? meta)...
2530: 28 6c 65 74 2a 20 28 28 64 65 6c 61 79 2d 77 61 (let* ((delay-wa
2540: 69 74 20 28 61 6c 69 73 74 2d 72 65 66 20 27 64 it (alist-ref 'd
2550: 65 6c 61 79 2d 77 61 69 74 20 6d 65 74 61 29 29 elay-wait meta))
2560: 29 0a 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 )... (if (and
2570: 28 6e 75 6d 62 65 72 3f 20 64 65 6c 61 79 2d 77 (number? delay-w
2580: 61 69 74 29 0a 09 09 09 20 20 20 20 28 3e 20 64 ait).... (> d
2590: 65 6c 61 79 2d 77 61 69 74 20 30 29 29 0a 09 09 elay-wait 0))...
25a0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
25b0: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 . (debug:print 0
25c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
25d0: 72 74 2a 20 22 53 65 72 76 65 72 20 69 73 20 6c rt* "Server is l
25e0: 6f 61 64 65 64 2c 20 64 65 6c 61 79 69 6e 67 20 oaded, delaying
25f0: 22 64 65 6c 61 79 2d 77 61 69 74 22 20 73 65 63 "delay-wait" sec
2600: 6f 6e 64 73 22 29 0a 09 09 09 20 28 74 68 72 65 onds").... (thre
2610: 61 64 2d 73 6c 65 65 70 21 20 64 65 6c 61 79 2d ad-sleep! delay-
2620: 77 61 69 74 29 29 29 29 29 0a 09 20 20 20 20 20 wait)))))..
2630: 28 63 61 73 65 20 73 74 61 74 75 73 0a 09 20 20 (case status..
2640: 20 20 20 20 20 28 28 62 75 73 79 29 20 3b 3b 20 ((busy) ;;
2650: 72 65 73 75 6c 74 20 77 69 6c 6c 20 62 65 20 68 result will be h
2660: 6f 77 20 6c 6f 6e 67 20 74 68 65 20 73 65 72 76 ow long the serv
2670: 65 72 20 77 61 6e 74 73 20 79 6f 75 20 74 6f 20 er wants you to
2680: 64 65 6c 61 79 0a 09 09 28 6c 65 74 2a 20 28 28 delay...(let* ((
2690: 72 61 77 2d 64 6c 79 20 20 28 69 66 20 28 6e 75 raw-dly (if (nu
26a0: 6d 62 65 72 3f 20 72 65 73 75 6c 74 29 20 72 65 mber? result) re
26b0: 73 75 6c 74 20 30 2e 31 29 29 0a 09 09 20 20 20 sult 0.1))...
26c0: 20 20 20 20 28 64 6c 79 20 20 20 20 20 20 28 2b (dly (+
26d0: 20 72 61 77 2d 64 6c 79 20 28 2f 20 61 74 74 65 raw-dly (/ atte
26e0: 6d 70 74 6e 75 6d 20 31 30 29 29 29 29 20 3b 3b mptnum 10)))) ;;
26f0: 20 28 2a 20 72 61 77 2d 64 6c 79 20 28 2f 20 61 (* raw-dly (/ a
2700: 74 74 65 6d 70 74 6e 75 6d 20 32 29 29 29 29 0a ttemptnum 2)))).
2710: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
2720: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2730: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
2740: 73 65 72 76 65 72 20 66 6f 72 20 22 64 62 66 6e server for "dbfn
2750: 61 6d 65 22 20 69 73 20 62 75 73 79 2c 20 63 6d ame" is busy, cm
2760: 64 20 69 73 20 22 63 6d 64 22 2c 20 77 69 6c 6c d is "cmd", will
2770: 20 74 72 79 20 61 67 61 69 6e 20 69 6e 20 22 64 try again in "d
2780: 6c 79 22 20 73 65 63 6f 6e 64 73 2e 20 54 68 69 ly" seconds. Thi
2790: 73 20 69 73 20 61 74 74 65 6d 70 74 20 22 28 2d s is attempt "(-
27a0: 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 29 0a attemptnum 1)).
27b0: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
27c0: 70 21 20 64 6c 79 29 0a 09 09 20 20 28 74 74 3a p! dly)... (tt:
27d0: 68 61 6e 64 6c 65 72 20 20 74 74 64 61 74 20 63 handler ttdat c
27e0: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
27f0: 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 (+ attemptnum 1
2800: 29 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 ) readonly-mode
2810: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
2820: 65 20 6d 74 65 78 65 20 73 65 72 76 65 72 2d 73 e mtexe server-s
2830: 74 61 72 74 2d 70 72 6f 63 29 29 29 0a 09 20 20 tart-proc)))..
2840: 20 20 20 20 20 28 28 6c 6f 61 64 65 64 29 0a 09 ((loaded)..
2850: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
2860: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2870: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 65 72 t* "WARNING: ser
2880: 76 65 72 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 ver for "dbfname
2890: 22 20 69 73 20 6c 6f 61 64 65 64 2c 20 73 6c 6f " is loaded, slo
28a0: 77 69 6e 67 20 71 75 65 72 69 65 73 2e 22 29 0a wing queries.").
28b0: 09 09 28 74 74 3a 62 61 63 6b 6f 66 66 2d 69 6e ..(tt:backoff-in
28c0: 63 72 20 28 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 cr (tt-conn-host
28d0: 20 63 6f 6e 6e 29 28 74 74 2d 63 6f 6e 6e 2d 70 conn)(tt-conn-p
28e0: 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 09 72 65 73 ort conn))...res
28f0: 75 6c 74 29 20 3b 3b 20 28 74 74 3a 68 61 6e 64 ult) ;; (tt:hand
2900: 6c 65 72 20 20 74 74 64 61 74 20 63 6d 64 20 72 ler ttdat cmd r
2910: 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 2b 20 un-id params (+
2920: 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 72 65 attemptnum 1) re
2930: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e adonly-mode dbfn
2940: 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d 74 ame testsuite mt
2950: 65 78 65 29 29 0a 09 20 20 20 20 20 20 20 28 65 exe)).. (e
2960: 6c 73 65 0a 09 09 72 65 73 75 6c 74 29 29 29 0a lse...result))).
2970: 09 20 20 20 20 28 65 6c 73 65 20 3b 3b 20 64 69 . (else ;; di
2980: 64 20 6e 6f 74 20 72 65 63 65 69 76 65 20 70 72 d not receive pr
2990: 6f 70 65 72 6c 79 20 66 6f 72 6d 61 74 65 64 20 operly formated
29a0: 72 65 73 75 6c 74 0a 09 20 20 20 20 20 28 69 66 result.. (if
29b0: 20 28 6e 6f 74 20 72 65 73 29 20 3b 3b 20 74 74 (not res) ;; tt
29c0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 74 65 :send-receive te
29d0: 6c 6c 69 6e 67 20 75 73 20 74 68 61 74 20 63 6f lling us that co
29e0: 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 66 61 69 6c mmunication fail
29f0: 65 64 0a 09 09 20 28 6c 65 74 2a 20 28 28 68 6f ed... (let* ((ho
2a00: 73 74 20 20 20 20 28 74 74 2d 63 6f 6e 6e 2d 68 st (tt-conn-h
2a10: 6f 73 74 20 63 6f 6e 6e 29 29 0a 09 09 09 28 70 ost conn))....(p
2a20: 6f 72 74 20 20 20 20 28 74 74 2d 63 6f 6e 6e 2d ort (tt-conn-
2a30: 70 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 09 09 3b port conn))....;
2a40: 3b 20 28 64 62 66 6e 61 6d 65 20 28 74 74 2d 63 ; (dbfname (tt-c
2a50: 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 20 onn-port conn))
2a60: 3b 3b 20 31 39 32 2e 31 36 38 2e 30 2e 31 32 37 ;; 192.168.0.127
2a70: 3a 34 32 34 32 2d 37 32 36 39 32 34 3a 34 2e 64 :4242-726924:4.d
2a80: 62 0a 09 09 09 28 70 69 64 20 20 20 20 20 28 74 b....(pid (t
2a90: 74 2d 63 6f 6e 6e 2d 70 69 64 20 20 63 6f 6e 6e t-conn-pid conn
2aa0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2ab0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 73 65 ;;(se
2ac0: 72 76 69 6e 66 20 28 74 74 2d 63 6f 6e 6e 2d 73 rvinf (tt-conn-s
2ad0: 65 72 76 69 6e 66 2d 66 69 6c 65 20 63 6f 6e 6e ervinf-file conn
2ae0: 29 29 29 20 0a 09 09 09 28 73 65 72 76 69 6e 66 ))) ....(servinf
2af0: 20 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 69 6c (tt-servinf-fil
2b00: 65 20 74 74 64 61 74 29 29 29 20 3b 3b 20 28 63 e ttdat))) ;; (c
2b10: 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f 2e 73 onc areapath"/.s
2b20: 65 72 76 69 6e 66 6f 2f 22 68 6f 73 74 22 3a 22 ervinfo/"host":"
2b30: 70 6f 72 74 22 2d 22 70 69 64 22 3a 22 64 62 66 port"-"pid":"dbf
2b40: 6e 61 6d 65 29 29 29 20 3b 3b 20 54 4f 44 4f 2c name))) ;; TODO,
2b50: 20 75 73 65 20 28 73 65 72 76 65 72 3a 67 65 74 use (server:get
2b60: 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 72 -servinfo-dir ar
2b70: 65 61 70 61 74 68 29 0a 09 09 20 20 20 28 68 61 eapath)... (ha
2b80: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 74 sh-table-set! (t
2b90: 74 2d 63 6f 6e 6e 73 20 74 74 64 61 74 29 20 64 t-conns ttdat) d
2ba0: 62 66 6e 61 6d 65 20 23 66 29 20 3b 3b 20 63 6c bfname #f) ;; cl
2bb0: 65 61 72 20 6f 75 74 20 74 68 65 20 63 6f 6e 6e ear out the conn
2bc0: 20 66 6f 72 20 74 68 69 73 20 64 62 66 6e 61 6d for this dbfnam
2bd0: 65 20 74 6f 20 66 6f 72 63 65 20 66 69 6e 64 69 e to force findi
2be0: 6e 67 20 6e 65 77 20 73 65 72 76 65 72 0a 09 09 ng new server...
2bf0: 20 20 20 28 69 66 20 28 61 6e 64 20 73 65 72 76 (if (and serv
2c00: 69 6e 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 inf (file-exists
2c10: 3f 20 73 65 72 76 69 6e 66 29 29 0a 09 09 20 20 ? servinf))...
2c20: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 (begin....
2c30: 28 69 66 20 28 3c 20 61 74 74 65 6d 70 74 6e 75 (if (< attemptnu
2c40: 6d 20 31 30 29 0a 09 09 09 20 20 20 20 20 28 62 m 10).... (b
2c50: 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 egin.... (
2c60: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
2c70: 35 29 0a 09 09 09 20 20 20 20 20 20 20 28 74 74 5).... (tt
2c80: 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 :handler ttdat c
2c90: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
2ca0: 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 (+ attemptnum 1
2cb0: 29 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 ) readonly-mode
2cc0: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
2cd0: 65 20 6d 74 65 78 65 20 73 65 72 76 65 72 2d 73 e mtexe server-s
2ce0: 74 61 72 74 2d 70 72 6f 63 29 29 0a 09 09 09 20 tart-proc))....
2cf0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 (begin....
2d00: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2d10: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
2d20: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 6e 6f -port* "INFO: no
2d30: 20 72 65 73 70 6f 6e 73 65 20 66 72 6f 6d 20 73 response from s
2d40: 65 72 76 65 72 20 22 68 6f 73 74 22 3a 22 70 6f erver "host":"po
2d50: 72 74 22 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 rt" for "dbfname
2d60: 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 ).... (if
2d70: 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
2d80: 73 3f 20 73 65 72 76 69 6e 66 29 0a 09 09 09 09 s? servinf).....
2d90: 09 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d .(> (- (current-
2da0: 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d 6f seconds)(file-mo
2db0: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
2dc0: 73 65 72 76 69 6e 66 29 29 20 36 30 29 29 0a 09 servinf)) 60))..
2dd0: 09 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 09 ... (begin....
2de0: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
2df0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
2e00: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 22 g-port* "INFO: "
2e10: 73 65 72 76 69 6e 66 22 20 66 69 6c 65 20 73 65 servinf" file se
2e20: 65 6d 73 20 6f 6c 64 20 61 6e 64 20 6e 6f 20 70 ems old and no p
2e30: 69 6e 67 20 72 65 73 70 6f 6e 73 65 2c 20 72 65 ing response, re
2e40: 6d 6f 76 69 6e 67 20 69 74 2e 22 29 0a 09 09 09 moving it.")....
2e50: 09 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 . (handle-ex
2e60: 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 65 ceptions...... e
2e70: 78 6e 0a 09 09 09 09 20 20 20 20 20 20 20 23 66 xn..... #f
2e80: 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 6c ..... (del
2e90: 65 74 65 2d 66 69 6c 65 2a 20 73 65 72 76 69 6e ete-file* servin
2ea0: 66 29 29 0a 09 09 09 09 20 20 20 20 20 28 74 74 f))..... (tt
2eb0: 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 :handler ttdat c
2ec0: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
2ed0: 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 (+ attemptnum 1
2ee0: 29 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 ) readonly-mode
2ef0: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
2f00: 65 20 6d 74 65 78 65 20 73 65 72 76 65 72 2d 73 e mtexe server-s
2f10: 74 61 72 74 2d 70 72 6f 63 29 29 0a 09 09 09 09 tart-proc)).....
2f20: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 (begin.....
2f30: 20 20 20 3b 3b 20 73 74 61 72 74 20 73 65 72 76 ;; start serv
2f40: 65 72 20 2d 20 61 64 64 72 65 73 73 65 64 20 69 er - addressed i
2f50: 6e 20 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 n client-connect
2f60: 2d 74 6f 2d 73 65 72 76 65 72 0a 09 09 09 09 20 -to-server.....
2f70: 20 20 20 20 3b 3b 20 64 65 6c 61 79 20 20 20 20 ;; delay
2f80: 20 20 20 20 2d 20 61 64 64 72 65 73 73 65 64 20 - addressed
2f90: 69 6e 20 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 in client-connec
2fa0: 74 2d 74 6f 2d 73 65 72 76 65 72 0a 09 09 09 09 t-to-server.....
2fb0: 20 20 20 20 20 3b 3b 20 74 72 79 20 61 67 61 69 ;; try agai
2fc0: 6e 0a 09 09 09 09 20 20 20 20 20 28 74 68 72 65 n..... (thre
2fd0: 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 20 ad-sleep! 0.25)
2fe0: 3b 3b 20 64 75 6e 6e 6f 2c 20 49 20 74 68 69 6e ;; dunno, I thin
2ff0: 6b 20 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 k this needs to
3000: 62 65 20 68 65 72 65 0a 09 09 09 09 20 20 20 20 be here.....
3010: 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 (tt:handler ttd
3020: 61 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 at cmd run-id pa
3030: 72 61 6d 73 20 28 2b 20 61 74 74 65 6d 70 74 6e rams (+ attemptn
3040: 75 6d 20 31 29 20 72 65 61 64 6f 6e 6c 79 2d 6d um 1) readonly-m
3050: 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 74 ode dbfname test
3060: 73 75 69 74 65 20 6d 74 65 78 65 20 73 65 72 76 suite mtexe serv
3070: 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 29 29 0a er-start-proc)).
3080: 09 09 09 09 20 20 20 29 29 29 29 0a 09 09 20 20 .... ))))...
3090: 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6e (begin ;; n
30a0: 6f 20 73 65 72 76 65 72 20 66 69 6c 65 2c 20 64 o server file, d
30b0: 65 6c 61 79 20 61 6e 64 20 74 72 79 20 61 67 61 elay and try aga
30c0: 69 6e 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 in.... (debug:pr
30d0: 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c int 2 *default-l
30e0: 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 og-port* "INFO:
30f0: 63 6f 6e 6e 65 63 74 69 6f 6e 20 74 6f 20 73 65 connection to se
3100: 72 76 65 72 20 22 68 6f 73 74 22 3a 22 70 6f 72 rver "host":"por
3110: 74 22 20 62 72 6f 6b 65 6e 20 66 6f 72 20 22 64 t" broken for "d
3120: 62 66 6e 61 6d 65 22 2c 20 6e 6f 20 73 65 72 76 bfname", no serv
3130: 69 6e 66 20 66 69 6c 65 2e 20 53 65 72 76 65 72 inf file. Server
3140: 20 65 78 69 74 65 64 3f 20 22 29 0a 09 09 09 20 exited? ")....
3150: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
3160: 2e 35 29 0a 09 09 09 20 28 74 74 3a 68 61 6e 64 .5).... (tt:hand
3170: 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 75 ler ttdat cmd ru
3180: 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 2b 20 61 n-id params (+ a
3190: 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 72 65 61 ttemptnum 1) rea
31a0: 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e 61 donly-mode dbfna
31b0: 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d 74 65 me testsuite mte
31c0: 78 65 20 73 65 72 76 65 72 2d 73 74 61 72 74 2d xe server-start-
31d0: 70 72 6f 63 29 29 29 29 0a 09 09 20 28 62 65 67 proc))))... (beg
31e0: 69 6e 20 3b 3b 20 74 68 69 73 20 63 61 73 65 20 in ;; this case
31f0: 69 73 20 77 68 65 72 65 20 72 65 73 20 69 73 20 is where res is
3200: 6d 61 6c 66 6f 72 6d 65 64 2e 20 50 72 6f 62 61 malformed. Proba
3210: 62 6c 79 20 73 68 6f 75 6c 64 20 61 62 6f 72 74 bly should abort
3220: 0a 09 09 20 20 20 28 61 73 73 65 72 74 20 23 66 ... (assert #f
3230: 20 22 46 41 54 41 4c 3a 20 74 74 3a 68 61 6e 64 "FATAL: tt:hand
3240: 6c 65 72 20 72 65 63 65 69 76 65 64 20 62 61 64 ler received bad
3250: 20 64 61 74 61 20 22 72 65 73 29 0a 09 09 20 20 data "res)...
3260: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
3270: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
3280: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 67 6f 74 port* "INFO: got
3290: 20 63 6f 72 72 75 70 74 20 64 61 74 61 20 66 72 corrupt data fr
32a0: 6f 6d 20 73 65 72 76 65 72 20 22 68 6f 73 74 22 om server "host"
32b0: 3a 22 70 6f 72 74 22 2c 20 22 72 65 73 22 2c 20 :"port", "res",
32c0: 66 6f 72 20 22 64 62 66 6e 61 6d 65 22 2c 20 77 for "dbfname", w
32d0: 69 6c 6c 20 74 72 79 20 61 67 61 69 6e 2e 22 29 ill try again.")
32e0: 0a 09 09 20 20 20 3b 3b 20 28 74 74 3a 68 61 6e ... ;; (tt:han
32f0: 64 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 dler ttdat cmd r
3300: 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 2b 20 un-id params (+
3310: 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 72 65 attemptnum 1) re
3320: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e adonly-mode dbfn
3330: 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d 74 ame testsuite mt
3340: 65 78 65 29 0a 09 09 20 20 20 29 29 29 29 29 0a exe)... ))))).
3350: 09 28 62 65 67 69 6e 0a 09 20 20 28 74 68 72 65 .(begin.. (thre
3360: 61 64 2d 73 6c 65 65 70 21 20 31 29 20 3b 3b 20 ad-sleep! 1) ;;
3370: 6e 6f 20 63 6f 6e 6e 20 79 65 74 20 73 65 74 20 no conn yet set
3380: 75 70 2c 20 67 69 76 65 20 69 74 20 61 20 72 65 up, give it a re
3390: 73 74 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e st and try again
33a0: 0a 09 20 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 .. (tt:handler
33b0: 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 64 ttdat cmd run-id
33c0: 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e params attemptn
33d0: 75 6d 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 um readonly-mode
33e0: 20 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 dbfname testsui
33f0: 74 65 20 6d 74 65 78 65 20 73 65 72 76 65 72 2d te mtexe server-
3400: 73 74 61 72 74 2d 70 72 6f 63 29 29 29 29 29 0a start-proc))))).
3410: 0a 3b 3b 20 67 65 74 73 20 73 65 72 76 65 72 20 .;; gets server
3420: 69 6e 66 6f 20 61 6e 64 20 61 70 70 65 6e 64 73 info and appends
3430: 20 70 61 74 68 20 74 6f 20 73 65 72 76 65 72 20 path to server
3440: 66 69 6c 65 0a 3b 3b 20 73 6f 72 74 73 20 62 79 file.;; sorts by
3450: 20 61 67 65 2c 20 6f 6c 64 65 73 74 20 66 69 72 age, oldest fir
3460: 73 74 0a 3b 3b 0a 3b 3b 20 72 65 74 75 72 6e 73 st.;;.;; returns
3470: 20 6c 69 73 74 20 6f 66 20 28 68 6f 73 74 20 70 list of (host p
3480: 6f 72 74 20 73 74 61 72 74 73 65 63 6f 6e 64 73 ort startseconds
3490: 20 73 65 72 76 65 72 2d 69 64 20 73 65 72 76 69 server-id servi
34a0: 6e 66 6f 66 69 6c 65 29 0a 3b 3b 0a 28 64 65 66 nfofile).;;.(def
34b0: 69 6e 65 20 28 74 74 3a 67 65 74 2d 73 65 72 76 ine (tt:get-serv
34c0: 65 72 2d 69 6e 66 6f 2d 73 6f 72 74 65 64 20 74 er-info-sorted t
34d0: 74 64 61 74 20 64 62 66 6e 61 6d 65 29 0a 20 20 tdat dbfname).
34e0: 28 6c 65 74 2a 20 28 28 61 72 65 61 70 61 74 68 (let* ((areapath
34f0: 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 74 74 (tt-areapath tt
3500: 64 61 74 29 29 0a 09 20 28 73 66 69 6c 65 73 20 dat)).. (sfiles
3510: 20 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 (tt:find-serve
3520: 72 20 61 72 65 61 70 61 74 68 20 64 62 66 6e 61 r areapath dbfna
3530: 6d 65 29 29 0a 09 20 28 73 64 61 74 73 20 20 20 me)).. (sdats
3540: 20 28 66 69 6c 74 65 72 20 63 61 72 20 28 6d 61 (filter car (ma
3550: 70 20 74 74 3a 73 65 72 76 65 72 2d 67 65 74 2d p tt:server-get-
3560: 69 6e 66 6f 20 73 66 69 6c 65 73 29 29 29 20 3b info sfiles))) ;
3570: 3b 20 66 69 72 73 74 20 65 6c 65 6d 65 6e 74 20 ; first element
3580: 69 73 20 23 66 20 69 66 20 74 68 65 20 66 69 6c is #f if the fil
3590: 65 20 64 69 73 61 70 70 65 61 72 65 64 20 77 68 e disappeared wh
35a0: 69 6c 65 20 62 65 69 6e 67 20 72 65 61 64 0a 09 ile being read..
35b0: 20 28 73 6f 72 74 65 64 20 20 20 28 73 6f 72 74 (sorted (sort
35c0: 20 73 64 61 74 73 20 28 6c 61 6d 62 64 61 20 28 sdats (lambda (
35d0: 61 20 62 29 0a 09 09 09 09 20 28 6c 65 74 2a 20 a b)..... (let*
35e0: 28 28 73 74 61 72 74 61 20 28 6c 69 73 74 2d 72 ((starta (list-r
35f0: 65 66 20 61 20 32 29 29 0a 09 09 09 09 09 28 73 ef a 2))......(s
3600: 74 61 72 74 62 20 28 6c 69 73 74 2d 72 65 66 20 tartb (list-ref
3610: 62 20 32 29 29 29 0a 09 09 09 09 20 20 20 28 69 b 2)))..... (i
3620: 66 20 28 65 71 3f 20 73 74 61 72 74 61 20 73 74 f (eq? starta st
3630: 61 72 74 62 29 0a 09 09 09 09 20 20 20 20 20 20 artb).....
3640: 20 28 73 74 72 69 6e 67 3e 3f 20 28 6c 69 73 74 (string>? (list
3650: 2d 72 65 66 20 61 20 33 29 28 6c 69 73 74 2d 72 -ref a 3)(list-r
3660: 65 66 20 62 20 33 29 29 20 3b 3b 20 69 66 20 73 ef b 3)) ;; if s
3670: 65 72 76 65 72 73 20 73 74 61 72 74 65 64 20 61 ervers started a
3680: 74 20 73 61 6d 65 20 74 69 6d 65 20 6c 6f 6f 6b t same time look
3690: 20 61 74 20 73 65 72 76 65 72 2d 69 64 0a 09 09 at server-id...
36a0: 09 09 20 20 20 20 20 20 20 28 3c 20 73 74 61 72 .. (< star
36b0: 74 61 20 73 74 61 72 74 62 29 29 29 29 29 29 0a ta startb)))))).
36c0: 09 20 28 63 6f 75 6e 74 20 20 20 20 30 29 29 0a . (count 0)).
36d0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
36e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 72 65 63 29 (lambda (rec)
36f0: 0a 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 . (if (or
3700: 28 3e 20 28 6c 65 6e 67 74 68 20 73 6f 72 74 65 (> (length sorte
3710: 64 29 20 31 29 0a 09 20 20 20 20 20 20 20 28 63 d) 1).. (c
3720: 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d ommon:low-noise-
3730: 70 72 69 6e 74 20 31 32 30 20 22 73 65 72 76 65 print 120 "serve
3740: 72 20 69 6e 66 6f 20 73 6f 72 74 65 64 22 29 29 r info sorted"))
3750: 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
3760: 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 2 *default-log
3770: 2d 70 6f 72 74 2a 20 22 53 45 52 56 45 52 20 23 -port* "SERVER #
3780: 22 63 6f 75 6e 74 22 3a 20 22 28 73 74 72 69 6e "count": "(strin
3790: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
37a0: 61 70 20 63 6f 6e 63 20 73 6f 72 74 65 64 29 20 ap conc sorted)
37b0: 22 2c 20 22 29 29 29 0a 20 20 20 20 20 20 20 28 ", "))). (
37c0: 73 65 74 21 20 63 6f 75 6e 74 20 28 2b 20 63 6f set! count (+ co
37d0: 75 6e 74 20 31 29 29 29 0a 20 20 20 20 20 73 6f unt 1))). so
37e0: 72 74 65 64 29 0a 20 20 20 20 73 6f 72 74 65 64 rted). sorted
37f0: 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 )). .(define
3800: 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 (tt:send-receive
3810: 20 74 74 64 61 74 20 63 6f 6e 6e 20 63 6d 64 20 ttdat conn cmd
3820: 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 0a 20 run-id params).
3830: 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f (let* ((host-po
3840: 72 74 20 28 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 rt (tt-conn-host
3850: 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 20 3b 3b 20 -port conn)) ;;
3860: 28 63 6f 6e 63 20 28 74 74 2d 63 6f 6e 6e 2d 68 (conc (tt-conn-h
3870: 6f 73 74 20 63 6f 6e 6e 29 22 3a 22 28 74 74 2d ost conn)":"(tt-
3880: 63 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 conn-port conn))
3890: 29 0a 09 20 28 68 6f 73 74 20 20 20 20 20 20 28 ).. (host (
38a0: 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 20 63 6f 6e tt-conn-host con
38b0: 6e 29 29 0a 09 20 28 70 6f 72 74 20 20 20 20 20 n)).. (port
38c0: 20 28 74 74 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 (tt-conn-port c
38d0: 6f 6e 6e 29 29 0a 09 20 28 64 61 74 20 20 20 20 onn)).. (dat
38e0: 20 20 20 28 6c 69 73 74 20 63 6d 64 20 72 75 6e (list cmd run
38f0: 2d 69 64 20 70 61 72 61 6d 73 20 23 66 29 29 29 -id params #f)))
3900: 20 3b 3b 20 6e 6f 20 6d 65 74 61 20 64 61 74 61 ;; no meta data
3910: 20 79 65 74 0a 20 20 20 20 28 74 74 3a 73 65 6e yet. (tt:sen
3920: 64 2d 72 65 63 65 69 76 65 2d 64 69 72 65 63 74 d-receive-direct
3930: 20 68 6f 73 74 20 70 6f 72 74 20 64 61 74 29 29 host port dat))
3940: 29 0a 0a 28 64 65 66 73 74 72 75 63 74 20 74 74 )..(defstruct tt
3950: 3a 62 61 63 6b 6f 66 66 0a 20 20 28 6c 61 73 74 :backoff. (last
3960: 2d 69 6f 65 72 72 20 28 63 75 72 72 65 6e 74 2d -ioerr (current-
3970: 73 65 63 6f 6e 64 73 29 29 0a 20 20 28 6c 61 73 seconds)). (las
3980: 74 2d 61 64 6a 2d 74 20 28 63 75 72 72 65 6e 74 t-adj-t (current
3990: 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 28 77 61 -seconds)). (wa
39a0: 69 74 2d 64 65 6c 61 79 20 30 2e 31 29 29 0a 0a it-delay 0.1))..
39b0: 28 64 65 66 69 6e 65 20 2a 74 74 3a 62 61 63 6b (define *tt:back
39c0: 6f 66 66 2d 73 6d 6f 6f 74 68 69 6e 67 2a 20 28 off-smoothing* (
39d0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
39e0: 29 20 3b 3b 20 68 6f 73 74 3a 70 6f 72 74 20 3d ) ;; host:port =
39f0: 3e 20 6c 61 73 74 61 63 63 65 73 73 20 62 61 63 > lastaccess bac
3a00: 6b 6f 66 66 64 65 6c 61 79 20 29 0a 0a 28 64 65 koffdelay )..(de
3a10: 66 69 6e 65 20 28 74 74 3a 62 61 63 6b 6f 66 66 fine (tt:backoff
3a20: 2d 69 6e 63 72 20 68 6f 73 74 20 70 6f 72 74 29 -incr host port)
3a30: 20 3b 3b 20 63 61 6c 6c 20 69 66 20 74 63 70 20 ;; call if tcp
3a40: 66 61 69 6c 73 20 69 2f 6f 20 6e 65 74 0a 20 20 fails i/o net.
3a50: 28 6c 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f 72 (let* ((host-por
3a60: 74 20 28 63 6f 6e 63 20 68 6f 73 74 22 3a 22 70 t (conc host":"p
3a70: 6f 72 74 29 29 0a 09 20 28 62 6b 6f 66 66 20 20 ort)).. (bkoff
3a80: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
3a90: 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 74 3a 62 ef/default *tt:b
3aa0: 61 63 6b 6f 66 66 2d 73 6d 6f 6f 74 68 69 6e 67 ackoff-smoothing
3ab0: 2a 20 68 6f 73 74 2d 70 6f 72 74 20 23 66 29 29 * host-port #f))
3ac0: 29 0a 20 20 20 20 28 69 66 20 62 6b 6f 66 66 0a ). (if bkoff.
3ad0: 09 28 62 65 67 69 6e 0a 09 20 20 28 74 74 3a 62 .(begin.. (tt:b
3ae0: 61 63 6b 6f 66 66 2d 6c 61 73 74 2d 69 6f 65 72 ackoff-last-ioer
3af0: 72 2d 73 65 74 21 20 62 6b 6f 66 66 20 28 63 75 r-set! bkoff (cu
3b00: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
3b10: 09 20 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d 77 . (tt:backoff-w
3b20: 61 69 74 2d 64 65 6c 61 79 2d 73 65 74 21 20 62 ait-delay-set! b
3b30: 6b 6f 66 66 20 28 2b 20 28 74 74 3a 62 61 63 6b koff (+ (tt:back
3b40: 6f 66 66 2d 77 61 69 74 2d 64 65 6c 61 79 20 62 off-wait-delay b
3b50: 6b 6f 66 66 29 20 30 2e 31 29 29 29 0a 09 28 68 koff) 0.1)))..(h
3b60: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
3b70: 74 74 3a 62 61 63 6b 6f 66 66 2d 73 6d 6f 6f 74 tt:backoff-smoot
3b80: 68 69 6e 67 2a 20 68 6f 73 74 2d 70 6f 72 74 20 hing* host-port
3b90: 28 6d 61 6b 65 2d 74 74 3a 62 61 63 6b 6f 66 66 (make-tt:backoff
3ba0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
3bb0: 74 74 3a 62 61 63 6b 6f 66 66 2d 64 65 63 72 2d tt:backoff-decr-
3bc0: 61 6e 64 2d 77 61 69 74 20 68 6f 73 74 20 70 6f and-wait host po
3bd0: 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 6f rt). (let* ((ho
3be0: 73 74 2d 70 6f 72 74 20 28 63 6f 6e 63 20 68 6f st-port (conc ho
3bf0: 73 74 22 3a 22 70 6f 72 74 29 29 0a 09 20 28 62 st":"port)).. (b
3c00: 6b 6f 66 66 20 20 20 20 20 28 68 61 73 68 2d 74 koff (hash-t
3c10: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3c20: 20 2a 74 74 3a 62 61 63 6b 6f 66 66 2d 73 6d 6f *tt:backoff-smo
3c30: 6f 74 68 69 6e 67 2a 20 68 6f 73 74 2d 70 6f 72 othing* host-por
3c40: 74 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 t #f))). (if
3c50: 62 6b 6f 66 66 0a 09 28 6c 65 74 2a 20 28 28 77 bkoff..(let* ((w
3c60: 61 69 74 2d 64 65 6c 61 79 20 28 74 74 3a 62 61 ait-delay (tt:ba
3c70: 63 6b 6f 66 66 2d 77 61 69 74 2d 64 65 6c 61 79 ckoff-wait-delay
3c80: 20 62 6b 6f 66 66 29 29 0a 09 20 20 20 20 20 20 bkoff))..
3c90: 20 28 6c 61 73 74 2d 69 6f 65 72 72 20 28 74 74 (last-ioerr (tt
3ca0: 3a 62 61 63 6b 6f 66 66 2d 6c 61 73 74 2d 69 6f :backoff-last-io
3cb0: 65 72 72 20 62 6b 6f 66 66 29 29 0a 09 20 20 20 err bkoff))..
3cc0: 20 20 20 20 28 6c 61 73 74 2d 61 64 6a 2d 74 20 (last-adj-t
3cd0: 28 74 74 3a 62 61 63 6b 6f 66 66 2d 6c 61 73 74 (tt:backoff-last
3ce0: 2d 61 64 6a 2d 74 20 62 6b 6f 66 66 29 29 0a 09 -adj-t bkoff))..
3cf0: 20 20 20 20 20 20 20 28 64 65 6c 74 61 20 20 20 (delta
3d00: 20 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (- (current-s
3d10: 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d 61 64 6a econds) last-adj
3d20: 2d 74 29 29 0a 09 20 20 20 20 20 20 20 28 61 64 -t)).. (ad
3d30: 6a 20 20 20 20 20 20 20 20 28 2a 20 64 65 6c 74 j (* delt
3d40: 61 20 30 2e 30 30 31 29 29 20 3b 3b 20 69 74 20 a 0.001)) ;; it
3d50: 74 61 6b 65 73 20 31 30 30 20 73 65 63 6f 6e 64 takes 100 second
3d60: 73 20 74 6f 20 72 65 63 6f 76 65 72 20 66 72 6f s to recover fro
3d70: 6d 20 68 69 74 74 69 6e 67 20 61 6e 20 69 6f 20 m hitting an io
3d80: 65 72 72 0a 09 20 20 20 20 20 20 20 28 6e 65 77 err.. (new
3d90: 2d 77 61 69 74 20 20 20 28 69 66 20 28 3e 20 77 -wait (if (> w
3da0: 61 69 74 2d 64 65 6c 61 79 20 30 29 0a 09 09 09 ait-delay 0)....
3db0: 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 61 64 (if (> ad
3dc0: 6a 20 77 61 69 74 2d 64 65 6c 61 79 29 0a 09 09 j wait-delay)...
3dd0: 09 09 20 20 20 30 0a 09 09 09 09 20 20 20 28 2d .. 0..... (-
3de0: 20 77 61 69 74 2d 64 65 6c 61 79 20 61 64 6a 29 wait-delay adj)
3df0: 29 0a 09 09 09 20 20 20 20 20 20 20 30 29 29 29 ).... 0)))
3e00: 0a 09 20 20 28 69 66 20 28 3e 20 6e 65 77 2d 77 .. (if (> new-w
3e10: 61 69 74 20 30 29 0a 09 20 20 20 20 20 20 28 62 ait 0).. (b
3e20: 65 67 69 6e 0a 09 09 28 69 66 20 28 63 6f 6d 6d egin...(if (comm
3e30: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
3e40: 6e 74 20 31 30 20 22 64 65 6c 61 79 20 77 61 69 nt 10 "delay wai
3e50: 74 20 6d 65 73 73 61 67 65 22 29 0a 09 09 20 20 t message")...
3e60: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
3e70: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
3e80: 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 og-port* "Server
3e90: 20 6f 6e 20 68 6f 73 74 20 22 20 68 6f 73 74 20 on host " host
3ea0: 22 20 6c 6f 61 64 65 64 2c 20 44 65 6c 61 79 57 " loaded, DelayW
3eb0: 61 69 74 3a 20 22 6e 65 77 2d 77 61 69 74 29 29 ait: "new-wait))
3ec0: 0a 09 09 28 74 74 3a 62 61 63 6b 6f 66 66 2d 77 ...(tt:backoff-w
3ed0: 61 69 74 2d 64 65 6c 61 79 2d 73 65 74 21 20 62 ait-delay-set! b
3ee0: 6b 6f 66 66 20 6e 65 77 2d 77 61 69 74 29 0a 09 koff new-wait)..
3ef0: 09 28 74 74 3a 62 61 63 6b 6f 66 66 2d 6c 61 73 .(tt:backoff-las
3f00: 74 2d 61 64 6a 2d 74 2d 73 65 74 21 20 62 6b 6f t-adj-t-set! bko
3f10: 66 66 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f ff (current-seco
3f20: 6e 64 73 29 29 0a 09 09 28 74 68 72 65 61 64 2d nds))...(thread-
3f30: 73 6c 65 65 70 21 20 6e 65 77 2d 77 61 69 74 29 sleep! new-wait)
3f40: 29 0a 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 ).. (hash-t
3f50: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 2a 74 74 able-delete! *tt
3f60: 3a 62 61 63 6b 6f 66 66 2d 73 6d 6f 6f 74 68 69 :backoff-smoothi
3f70: 6e 67 2a 20 68 6f 73 74 2d 70 6f 72 74 29 29 29 ng* host-port)))
3f80: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 )))..(define (tt
3f90: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 64 69 :send-receive-di
3fa0: 72 65 63 74 20 68 6f 73 74 20 70 6f 72 74 20 64 rect host port d
3fb0: 61 74 20 23 21 6b 65 79 20 28 70 69 6e 67 2d 6d at #!key (ping-m
3fc0: 6f 64 65 20 23 66 29 28 74 72 69 65 73 2d 72 65 ode #f)(tries-re
3fd0: 6d 61 69 6e 69 6e 67 20 32 35 29 29 0a 20 20 28 maining 25)). (
3fe0: 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 assert (number?
3ff0: 70 6f 72 74 29 20 22 46 41 54 41 4c 3a 20 74 74 port) "FATAL: tt
4000: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 64 69 :send-receive-di
4010: 72 65 63 74 20 63 61 6c 6c 65 64 20 77 69 74 68 rect called with
4020: 20 20 61 20 70 6f 72 74 20 74 68 61 74 20 69 73 a port that is
4030: 20 6e 6f 74 20 61 20 6e 75 6d 62 65 72 20 22 70 not a number "p
4040: 6f 72 74 29 0a 20 20 28 74 74 3a 62 61 63 6b 6f ort). (tt:backo
4050: 66 66 2d 64 65 63 72 2d 61 6e 64 2d 77 61 69 74 ff-decr-and-wait
4060: 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 28 6c host port). (l
4070: 65 74 2a 20 28 28 72 65 74 72 79 20 20 20 20 20 et* ((retry
4080: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
4090: 09 09 09 20 20 20 28 74 74 3a 73 65 6e 64 2d 72 ... (tt:send-r
40a0: 65 63 65 69 76 65 2d 64 69 72 65 63 74 20 68 6f eceive-direct ho
40b0: 73 74 20 70 6f 72 74 20 64 61 74 20 74 72 69 65 st port dat trie
40c0: 73 2d 72 65 6d 61 69 6e 69 6e 67 3a 20 28 2d 20 s-remaining: (-
40d0: 74 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e 67 20 tries-remaining
40e0: 31 29 29 29 29 0a 09 20 28 66 75 6c 6c 2d 65 72 1)))).. (full-er
40f0: 72 2d 70 72 69 6e 74 20 28 6c 61 6d 62 64 61 20 r-print (lambda
4100: 28 65 78 6e 20 6d 73 67 29 0a 09 09 09 20 20 20 (exn msg)....
4110: 28 69 66 20 28 63 6f 6e 64 69 74 69 6f 6e 3f 20 (if (condition?
4120: 65 78 6e 29 0a 09 09 09 20 20 20 20 20 20 20 28 exn).... (
4130: 62 65 67 69 6e 0a 09 09 09 09 20 28 70 70 20 28 begin..... (pp (
4140: 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 condition->list
4150: 65 78 6e 29 20 2a 64 65 66 61 75 6c 74 2d 6c 6f exn) *default-lo
4160: 67 2d 70 6f 72 74 2a 29 0a 09 09 09 09 20 28 70 g-port*)..... (p
4170: 70 20 64 61 74 20 2a 64 65 66 61 75 6c 74 2d 6c p dat *default-l
4180: 6f 67 2d 70 6f 72 74 2a 29 0a 09 09 09 09 20 28 og-port*)..... (
4190: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
41a0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
41b0: 20 6d 73 67 0a 09 09 09 09 09 20 20 20 20 20 20 msg......
41c0: 22 2c 20 65 72 72 6f 72 3a 20 22 20 20 20 20 20 ", error: "
41d0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
41e0: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
41f0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 20 20 65 xn 'message) e
4200: 78 6e 29 0a 09 09 09 09 09 20 20 20 20 20 20 22 xn)...... "
4210: 2c 20 61 72 67 75 6d 65 6e 74 73 3a 20 22 20 28 , arguments: " (
4220: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
4230: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
4240: 6e 20 27 61 72 67 75 6d 65 6e 74 73 29 20 65 78 n 'arguments) ex
4250: 6e 29 0a 09 09 09 09 09 20 20 20 20 20 20 22 2c n)...... ",
4260: 20 6c 6f 63 61 74 69 6f 6e 3a 20 22 20 20 28 28 location: " ((
4270: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
4280: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
4290: 20 27 6c 6f 63 61 74 69 6f 6e 29 20 20 65 78 6e 'location) exn
42a0: 29 0a 09 09 09 09 09 20 20 20 20 20 20 29 29 0a )...... )).
42b0: 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
42c0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
42d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 6d 73 67 20 t-log-port* msg
42e0: 22 28 6e 6f 74 65 3a 20 65 78 6e 3d 22 65 78 6e "(note: exn="exn
42f0: 22 2c 20 69 73 20 6e 6f 74 20 61 20 63 6f 6e 64 ", is not a cond
4300: 69 74 69 6f 6e 20 6f 62 6a 65 63 74 2e 22 29 29 ition object."))
4310: 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 69 74 69 ))). (conditi
4320: 6f 6e 2d 63 61 73 65 0a 20 20 20 20 20 28 6c 65 on-case. (le
4330: 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 t-values (((inp
4340: 6f 75 70 29 28 74 63 70 2d 63 6f 6e 6e 65 63 74 oup)(tcp-connect
4350: 20 68 6f 73 74 20 70 6f 72 74 29 29 29 0a 20 20 host port))).
4360: 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 (let ((res
4370: 28 69 66 20 28 61 6e 64 20 69 6e 70 20 6f 75 70 (if (and inp oup
4380: 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e )... (begin
4390: 0a 09 09 09 28 73 65 72 69 61 6c 69 7a 65 20 64 ....(serialize d
43a0: 61 74 20 6f 75 70 29 0a 09 09 09 28 63 6c 6f 73 at oup)....(clos
43b0: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 e-output-port ou
43c0: 70 29 0a 09 09 09 28 64 65 73 65 72 69 61 6c 69 p)....(deseriali
43d0: 7a 65 20 69 6e 70 29 29 0a 09 09 20 20 20 20 20 ze inp))...
43e0: 20 29 29 29 0a 09 20 28 63 6c 6f 73 65 2d 69 6e ))).. (close-in
43f0: 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 09 20 put-port inp)..
4400: 28 6d 61 74 63 68 20 72 65 73 0a 09 20 20 20 28 (match res.. (
4410: 28 72 65 73 75 6c 74 20 65 78 6e 2d 72 65 73 75 (result exn-resu
4420: 6c 74 20 73 74 64 6f 75 74 2d 72 65 73 75 6c 74 lt stdout-result
4430: 29 0a 09 20 20 20 20 28 69 66 20 65 78 6e 2d 72 ).. (if exn-r
4440: 65 73 75 6c 74 0a 09 09 28 66 75 6c 6c 2d 65 72 esult...(full-er
4450: 72 2d 70 72 69 6e 74 20 65 78 6e 2d 72 65 73 75 r-print exn-resu
4460: 6c 74 20 22 45 52 52 4f 52 3a 20 53 65 72 76 65 lt "ERROR: Serve
4470: 72 20 73 69 64 65 20 65 78 63 65 70 74 69 6f 6e r side exception
4480: 20 64 65 74 65 63 74 65 64 22 29 29 0a 09 20 20 detected"))..
4490: 20 20 28 69 66 20 73 74 64 6f 75 74 2d 72 65 73 (if stdout-res
44a0: 75 6c 74 0a 09 09 28 64 65 62 75 67 3a 70 72 69 ult...(debug:pri
44b0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
44c0: 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 g-port* "ERROR:
44d0: 4f 75 74 70 75 74 20 64 65 74 65 63 74 65 64 20 Output detected
44e0: 6f 6e 20 73 74 64 6f 75 74 20 6f 6e 20 73 65 72 on stdout on ser
44f0: 76 65 72 20 73 69 64 65 20 65 78 65 63 75 74 69 ver side executi
4500: 6f 6e 20 3d 3e 20 22 73 74 64 6f 75 74 2d 72 65 on => "stdout-re
4510: 73 75 6c 74 29 29 0a 09 20 20 20 20 72 65 73 75 sult)).. resu
4520: 6c 74 29 0a 09 20 20 20 28 65 6c 73 65 0a 09 20 lt).. (else..
4530: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
4540: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
4550: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 73 65 72 ort* "ERROR: ser
4560: 76 65 72 20 72 65 74 75 72 6e 65 64 20 6e 6f 6e ver returned non
4570: 2d 73 74 61 6e 64 61 72 64 20 6f 75 74 70 75 74 -standard output
4580: 3a 20 22 72 65 73 29 0a 09 20 20 20 20 23 66 29 : "res).. #f)
4590: 29 29 29 0a 20 20 20 20 20 28 65 78 6e 20 28 69 ))). (exn (i
45a0: 6f 2d 65 72 72 6f 72 29 0a 09 20 20 28 66 75 6c o-error).. (ful
45b0: 6c 2d 65 72 72 2d 70 72 69 6e 74 20 65 78 6e 20 l-err-print exn
45c0: 20 22 45 52 52 4f 52 3a 20 69 2f 6f 20 65 72 72 "ERROR: i/o err
45d0: 6f 72 22 29 0a 09 20 20 28 74 74 3a 62 61 63 6b or").. (tt:back
45e0: 6f 66 66 2d 69 6e 63 72 20 68 6f 73 74 20 70 6f off-incr host po
45f0: 72 74 29 0a 09 20 20 23 66 29 0a 20 20 20 20 20 rt).. #f).
4600: 28 65 78 6e 20 28 69 2f 6f 20 6e 65 74 29 0a 09 (exn (i/o net)..
4610: 20 20 28 69 66 20 70 69 6e 67 2d 6d 6f 64 65 0a (if ping-mode.
4620: 09 20 20 20 20 20 20 23 66 0a 09 20 20 20 20 20 . #f..
4630: 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 20 20 28 (cond.. (
4640: 28 3e 20 20 74 72 69 65 73 2d 72 65 6d 61 69 6e (> tries-remain
4650: 69 6e 67 20 34 29 20 3b 3b 20 73 65 72 76 65 72 ing 4) ;; server
4660: 20 6c 69 6b 65 6c 79 20 64 65 66 75 6e 63 74 0a likely defunct.
4670: 09 09 28 74 74 3a 62 61 63 6b 6f 66 66 2d 69 6e ..(tt:backoff-in
4680: 63 72 20 68 6f 73 74 20 70 6f 72 74 29 0a 09 09 cr host port)...
4690: 23 66 29 0a 09 20 20 20 20 20 20 20 28 28 3e 3d #f).. ((>=
46a0: 20 74 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e 67 tries-remaining
46b0: 20 30 29 0a 09 09 28 6c 65 74 2a 20 28 28 62 61 0)...(let* ((ba
46c0: 63 6b 6f 66 66 2d 64 65 6c 61 79 20 28 6d 61 78 ckoff-delay (max
46d0: 20 28 2a 20 28 2d 20 32 36 20 74 72 69 65 73 2d (* (- 26 tries-
46e0: 72 65 6d 61 69 6e 69 6e 67 29 20 30 2e 31 29 20 remaining) 0.1)
46f0: 31 2e 30 29 29 29 0a 09 09 20 20 28 64 65 62 75 1.0)))... (debu
4700: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
4710: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
4720: 52 4e 49 4e 47 3a 20 54 43 50 20 6f 76 65 72 6c RNING: TCP overl
4730: 6f 61 64 2c 20 74 72 79 69 6e 67 20 61 67 61 69 oad, trying agai
4740: 6e 20 69 6e 20 22 62 61 63 6b 6f 66 66 2d 64 65 n in "backoff-de
4750: 6c 61 79 22 73 2e 22 29 0a 09 09 20 20 28 74 68 lay"s.")... (th
4760: 72 65 61 64 2d 73 6c 65 65 70 21 20 62 61 63 6b read-sleep! back
4770: 6f 66 66 2d 64 65 6c 61 79 29 0a 09 09 20 20 28 off-delay)... (
4780: 74 74 3a 62 61 63 6b 6f 66 66 2d 69 6e 63 72 20 tt:backoff-incr
4790: 68 6f 73 74 20 70 6f 72 74 29 0a 09 09 20 20 28 host port)... (
47a0: 72 65 74 72 79 29 29 0a 09 09 3b 3b 20 28 61 73 retry))...;; (as
47b0: 73 65 72 74 20 23 66 20 22 46 41 54 41 4c 3a 20 sert #f "FATAL:
47c0: 54 6f 6f 20 6d 61 6e 79 20 72 65 74 72 69 65 73 Too many retries
47d0: 20 69 6e 20 74 74 3a 73 65 6e 64 2d 72 65 63 65 in tt:send-rece
47e0: 69 76 65 2d 64 69 72 65 63 74 22 29 0a 09 09 29 ive-direct")...)
47f0: 0a 09 20 20 20 20 20 20 20 28 65 6c 73 65 20 23 .. (else #
4800: 66 29 29 29 29 0a 20 20 20 20 20 28 65 78 6e 20 f)))). (exn
4810: 28 29 0a 09 20 20 28 66 75 6c 6c 2d 65 72 72 2d ().. (full-err-
4820: 70 72 69 6e 74 20 65 78 6e 20 22 55 6e 68 61 6e print exn "Unhan
4830: 64 6c 65 64 20 65 78 63 65 70 74 69 6f 6e 20 66 dled exception f
4840: 72 6f 6d 20 63 6c 69 65 6e 74 20 73 69 64 65 2e rom client side.
4850: 22 29 0a 09 20 20 23 66 29 29 29 29 0a 0a 0a 3b ").. #f))))...;
4860: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
4870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48a0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 73 65 72 76 65 =======.;; serve
48b0: 72 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d r.;;============
48c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
4900: 69 6e 65 20 28 74 74 3a 73 79 6e 63 2d 64 62 73 ine (tt:sync-dbs
4910: 20 74 74 64 61 74 29 0a 20 20 23 66 29 0a 0a 3b ttdat). #f)..;
4920: 3b 20 73 74 61 72 74 20 74 68 65 20 6c 69 73 74 ; start the list
4930: 65 6e 65 72 20 61 6e 64 20 73 74 61 72 74 20 72 ener and start r
4940: 65 73 70 6f 6e 64 69 6e 67 20 74 6f 20 72 65 71 esponding to req
4950: 75 65 73 74 73 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 uests.;;.;; NOTE
4960: 3a 20 6f 72 67 61 6e 69 73 65 20 62 79 20 64 62 : organise by db
4970: 66 6e 61 6d 65 2c 20 6e 6f 74 20 72 75 6e 2d 69 fname, not run-i
4980: 64 20 73 6f 20 77 65 20 64 6f 6e 27 74 20 6e 65 d so we don't ne
4990: 65 64 0a 3b 3b 20 20 20 20 20 20 20 74 6f 20 70 ed.;; to p
49a0: 75 6c 6c 20 69 6e 20 6d 6f 72 65 20 6d 6f 64 75 ull in more modu
49b0: 6c 65 73 0a 3b 3b 0a 3b 3b 20 54 68 69 73 20 69 les.;;.;; This i
49c0: 73 20 74 68 65 20 72 6f 75 74 69 6e 65 20 63 61 s the routine ca
49d0: 6c 6c 65 64 20 69 6e 20 6d 65 67 61 74 65 73 74 lled in megatest
49e0: 2e 73 63 6d 20 74 6f 20 73 74 61 72 74 20 61 20 .scm to start a
49f0: 73 65 72 76 65 72 2e 20 4e 4f 54 45 3a 20 73 65 server. NOTE: se
4a00: 71 75 65 6e 63 65 20 69 73 20 64 69 66 66 65 72 quence is differ
4a10: 65 6e 74 20 66 6f 72 20 6d 61 69 6e 2e 64 62 20 ent for main.db
4a20: 76 73 2e 20 58 2e 64 62 0a 3b 3b 0a 3b 3b 20 53 vs. X.db.;;.;; S
4a30: 65 72 76 65 72 20 76 69 61 62 69 6c 69 74 79 20 erver viability
4a40: 69 73 20 63 68 65 63 6b 65 64 20 69 6e 20 6b 65 is checked in ke
4a50: 65 70 2d 72 75 6e 6e 69 6e 67 2e 20 42 6c 69 6e ep-running. Blin
4a60: 64 6c 79 20 73 74 61 72 74 20 61 6e 64 20 72 75 dly start and ru
4a70: 6e 20 68 65 72 65 2e 0a 3b 3b 0a 28 64 65 66 69 n here..;;.(defi
4a80: 6e 65 20 28 74 74 3a 73 74 61 72 74 2d 73 65 72 ne (tt:start-ser
4a90: 76 65 72 20 61 72 65 61 70 61 74 68 20 72 75 6e ver areapath run
4aa0: 2d 69 64 20 64 62 66 6e 61 6d 65 2d 69 6e 20 68 -id dbfname-in h
4ab0: 61 6e 64 6c 65 72 20 6b 65 79 73 29 0a 20 20 28 andler keys). (
4ac0: 61 73 73 65 72 74 20 61 72 65 61 70 61 74 68 20 assert areapath
4ad0: 22 46 41 54 41 4c 3a 20 61 72 65 61 70 61 74 68 "FATAL: areapath
4ae0: 20 6e 6f 74 20 70 72 6f 76 69 64 65 64 20 66 6f not provided fo
4af0: 72 20 74 74 3a 73 74 61 72 74 2d 73 65 72 76 65 r tt:start-serve
4b00: 72 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 74 r"). (let* ((tt
4b10: 64 61 74 20 20 20 28 6d 61 6b 65 2d 74 74 20 61 dat (make-tt a
4b20: 72 65 61 70 61 74 68 3a 20 61 72 65 61 70 61 74 reapath: areapat
4b30: 68 29 29 0a 09 20 28 64 62 66 6e 61 6d 65 20 28 h)).. (dbfname (
4b40: 6f 72 20 64 62 66 6e 61 6d 65 2d 69 6e 20 28 64 or dbfname-in (d
4b50: 62 6d 6f 64 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 bmod:run-id->dbf
4b60: 6e 61 6d 65 20 72 75 6e 2d 69 64 29 29 29 29 0a name run-id)))).
4b70: 20 20 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 (set! *serve
4b80: 72 2d 69 6e 66 6f 2a 20 74 74 64 61 74 29 0a 20 r-info* ttdat).
4b90: 20 20 20 28 6c 65 74 2a 20 28 28 64 62 73 74 72 (let* ((dbstr
4ba0: 75 63 74 20 20 20 28 64 62 6d 6f 64 3a 6f 70 65 uct (dbmod:ope
4bb0: 6e 2d 64 62 6d 6f 64 64 62 20 61 72 65 61 70 61 n-dbmoddb areapa
4bc0: 74 68 20 72 75 6e 2d 69 64 20 64 62 66 6e 61 6d th run-id dbfnam
4bd0: 65 20 28 64 62 66 69 6c 65 3a 64 62 2d 69 6e 69 e (dbfile:db-ini
4be0: 74 2d 70 72 6f 63 29 20 6b 65 79 73 29 29 29 0a t-proc) keys))).
4bf0: 20 20 20 20 20 20 28 74 74 2d 68 61 6e 64 6c 65 (tt-handle
4c00: 72 2d 73 65 74 21 20 74 74 64 61 74 20 28 68 61 r-set! ttdat (ha
4c10: 6e 64 6c 65 72 20 64 62 73 74 72 75 63 74 29 29 ndler dbstruct))
4c20: 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 . (let* ((s
4c30: 65 72 76 69 6e 66 2d 63 72 65 61 74 65 64 20 23 ervinf-created #
4c40: 66 29 0a 09 20 20 20 20 20 28 74 63 70 2d 74 68 f).. (tcp-th
4c50: 72 65 61 64 20 20 20 20 20 20 28 6d 61 6b 65 2d read (make-
4c60: 74 68 72 65 61 64 0a 09 09 09 20 20 20 20 20 20 thread....
4c70: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 (lambda ().....
4c80: 20 3b 3b 20 4e 4f 54 45 3a 20 74 74 2d 70 6f 72 ;; NOTE: tt-por
4c90: 74 20 61 6e 64 20 74 74 2d 68 6f 73 74 20 61 72 t and tt-host ar
4ca0: 65 20 73 65 74 20 69 6e 20 63 6f 6e 6e 65 63 74 e set in connect
4cb0: 2d 6c 69 73 74 65 6e 65 72 20 77 68 69 63 68 20 -listener which
4cc0: 69 73 20 63 61 6c 6c 65 64 20 75 6e 64 65 72 20 is called under
4cd0: 74 74 3a 73 74 61 72 74 2d 74 63 70 2d 73 65 72 tt:start-tcp-ser
4ce0: 76 65 72 0a 09 09 09 09 20 28 74 74 3a 73 74 61 ver..... (tt:sta
4cf0: 72 74 2d 74 63 70 2d 73 65 72 76 65 72 20 74 74 rt-tcp-server tt
4d00: 64 61 74 29 29 20 3b 3b 20 73 74 61 72 74 20 74 dat)) ;; start t
4d10: 68 65 20 74 63 70 2d 73 65 72 76 65 72 20 77 68 he tcp-server wh
4d20: 69 63 68 20 61 70 70 6c 69 65 73 20 68 61 6e 64 ich applies hand
4d30: 6c 65 72 20 74 6f 20 69 6e 63 6f 6d 69 6e 67 20 ler to incoming
4d40: 64 61 74 61 0a 09 09 09 20 20 20 20 20 20 20 22 data.... "
4d50: 74 63 70 2d 73 65 72 76 65 72 2d 74 68 72 65 61 tcp-server-threa
4d60: 64 22 29 29 0a 09 20 20 20 20 20 28 72 75 6e 2d d")).. (run-
4d70: 74 68 72 65 61 64 20 20 20 20 20 20 28 6d 61 6b thread (mak
4d80: 65 2d 74 68 72 65 61 64 0a 09 09 09 20 20 20 20 e-thread....
4d90: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
4da0: 09 09 20 28 74 74 3a 6b 65 65 70 2d 72 75 6e 6e .. (tt:keep-runn
4db0: 69 6e 67 20 74 74 64 61 74 20 64 62 66 6e 61 6d ing ttdat dbfnam
4dc0: 65 20 64 62 73 74 72 75 63 74 29 29 29 29 29 0a e dbstruct))))).
4dd0: 09 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 .(thread-start!
4de0: 74 63 70 2d 74 68 72 65 61 64 29 0a 0a 09 28 6c tcp-thread)...(l
4df0: 65 74 2a 20 28 28 61 72 65 61 70 61 74 68 20 20 et* ((areapath
4e00: 20 20 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 (tt-areapath
4e10: 74 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 ttdat))..
4e20: 28 6e 6f 73 79 6e 63 64 62 70 61 74 68 20 28 63 (nosyncdbpath (c
4e30: 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f 2e 6d onc areapath"/.m
4e40: 74 64 62 22 29 29 0a 09 20 20 20 20 20 20 20 28 tdb")).. (
4e50: 73 65 72 76 65 72 73 20 20 20 20 20 20 3b 3b 20 servers ;;
4e60: 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 72 20 (tt:find-server
4e70: 61 72 65 61 70 61 74 68 20 64 62 66 6e 61 6d 65 areapath dbfname
4e80: 29 29 29 0a 09 09 28 74 74 3a 67 65 74 2d 73 65 )))...(tt:get-se
4e90: 72 76 65 72 2d 69 6e 66 6f 2d 73 6f 72 74 65 64 rver-info-sorted
4ea0: 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 29 ttdat dbfname))
4eb0: 20 3b 3b 20 28 68 6f 73 74 20 70 6f 72 74 20 73 ;; (host port s
4ec0: 74 61 72 74 73 65 63 6f 6e 64 73 20 73 65 72 76 tartseconds serv
4ed0: 65 72 2d 69 64 20 73 65 72 76 69 6e 66 6f 66 69 er-id servinfofi
4ee0: 6c 65 29 0a 09 20 20 20 20 20 20 20 28 67 6f 6f le).. (goo
4ef0: 64 2d 73 72 76 72 73 20 20 0a 09 09 3b 3b 20 63 d-srvrs ...;; c
4f00: 6f 6e 74 61 63 74 20 73 65 72 76 65 72 73 20 76 ontact servers v
4f10: 69 61 20 70 69 6e 67 2c 20 69 66 20 6e 6f 20 72 ia ping, if no r
4f20: 65 73 70 6f 6e 73 65 20 72 65 6d 6f 76 65 20 74 esponse remove t
4f30: 68 65 20 2e 73 65 72 76 69 6e 66 6f 20 66 69 6c he .servinfo fil
4f40: 65 0a 09 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 e...(let loop ((
4f50: 73 65 72 76 72 73 20 20 20 20 20 73 65 72 76 65 servrs serve
4f60: 72 73 29 0a 09 09 09 20 20 20 28 70 72 69 6d 65 rs).... (prime
4f70: 2d 68 6f 73 74 20 23 66 29 0a 09 09 09 20 20 20 -host #f)....
4f80: 28 72 65 73 75 6c 74 20 20 20 20 27 28 29 29 29 (result '()))
4f90: 0a 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ... (if (null?
4fa0: 73 65 72 76 72 73 29 0a 09 09 20 20 20 20 20 20 servrs)...
4fb0: 28 72 65 76 65 72 73 65 20 72 65 73 75 6c 74 29 (reverse result)
4fc0: 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ... (let* (
4fd0: 28 73 65 72 76 64 61 74 20 28 63 61 72 20 73 65 (servdat (car se
4fe0: 72 76 72 73 29 29 29 0a 09 09 09 28 6d 61 74 63 rvrs)))....(matc
4ff0: 68 20 73 65 72 76 64 61 74 0a 09 09 09 20 20 20 h servdat....
5000: 20 20 28 28 68 6f 73 74 20 70 6f 72 74 20 73 74 ((host port st
5010: 61 72 74 73 65 63 6f 6e 64 73 20 73 65 72 76 65 artseconds serve
5020: 72 2d 69 64 20 73 65 72 76 69 6e 66 6f 66 69 6c r-id servinfofil
5030: 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 e).... (let
5040: 2a 20 28 28 70 69 6e 67 2d 72 65 73 20 20 28 74 * ((ping-res (t
5050: 74 3a 74 69 6d 65 64 2d 70 69 6e 67 20 68 6f 73 t:timed-ping hos
5060: 74 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 t port server-id
5070: 29 29 0a 09 09 09 09 20 20 20 20 20 28 67 6f 6f ))..... (goo
5080: 64 2d 70 69 6e 67 20 28 6d 61 74 63 68 20 70 69 d-ping (match pi
5090: 6e 67 2d 72 65 73 0a 09 09 09 09 09 09 20 20 20 ng-res.......
50a0: 28 28 72 65 73 75 6c 74 20 2e 20 70 69 6e 67 2d ((result . ping-
50b0: 74 69 6d 65 29 0a 09 09 09 09 09 09 20 20 20 20 time).......
50c0: 28 6e 6f 74 20 72 65 73 75 6c 74 29 29 20 3b 3b (not result)) ;;
50d0: 20 77 65 20 63 6f 75 6c 64 6e 27 74 20 72 65 61 we couldn't rea
50e0: 63 68 20 74 68 65 20 73 65 72 76 65 72 20 6f 72 ch the server or
50f0: 20 69 74 20 77 61 73 20 6e 6f 74 20 61 20 6d 65 it was not a me
5100: 67 61 74 65 73 74 20 73 65 72 76 65 72 0a 09 09 gatest server...
5110: 09 09 09 09 20 20 20 28 65 6c 73 65 20 23 66 29 .... (else #f)
5120: 29 29 20 3b 3b 20 74 68 65 20 70 69 6e 67 20 66 )) ;; the ping f
5130: 61 69 6c 65 64 20 63 6f 6d 70 6c 65 74 65 6c 79 ailed completely
5140: 3f 0a 09 09 09 09 20 20 20 20 20 28 73 61 6d 65 ?..... (same
5150: 2d 68 6f 73 74 20 28 6f 72 20 28 6e 6f 74 20 70 -host (or (not p
5160: 72 69 6d 65 2d 68 6f 73 74 29 20 3b 3b 20 69 2e rime-host) ;; i.
5170: 65 2e 20 74 68 69 73 20 69 73 20 74 68 65 20 66 e. this is the f
5180: 69 72 73 74 20 68 6f 73 74 0a 09 09 09 09 09 09 irst host.......
5190: 20 20 20 20 28 65 71 75 61 6c 3f 20 70 72 69 6d (equal? prim
51a0: 65 2d 68 6f 73 74 20 68 6f 73 74 29 29 29 0a 09 e-host host)))..
51b0: 09 09 09 20 20 20 20 20 28 6b 65 65 70 2d 73 72 ... (keep-sr
51c0: 76 20 20 28 61 6e 64 20 67 6f 6f 64 2d 70 69 6e v (and good-pin
51d0: 67 20 73 61 6d 65 2d 68 6f 73 74 29 29 29 0a 09 g same-host)))..
51e0: 09 09 09 28 69 66 20 6b 65 65 70 2d 73 72 76 09 ...(if keep-srv.
51f0: 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 ..... (loop (
5200: 63 64 72 20 73 65 72 76 72 73 29 0a 09 09 09 09 cdr servrs).....
5210: 09 20 20 68 6f 73 74 0a 09 09 09 09 09 20 20 28 . host...... (
5220: 63 6f 6e 73 20 73 65 72 76 64 61 74 20 72 65 73 cons servdat res
5230: 75 6c 74 29 29 0a 09 09 09 09 20 20 20 20 28 62 ult))..... (b
5240: 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 28 egin..... (
5250: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
5260: 73 0a 09 09 09 09 20 20 20 20 20 20 20 65 78 6e s..... exn
5270: 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 ..... (deb
5280: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
5290: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
52a0: 74 2a 20 22 45 72 72 6f 72 20 72 65 6d 6f 76 69 t* "Error removi
52b0: 6e 67 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 ng server info f
52c0: 69 6c 65 3a 20 22 73 65 72 76 69 6e 66 6f 66 69 ile: "servinfofi
52d0: 6c 65 22 2c 20 22 0a 09 09 09 09 09 09 09 20 28 le", "........ (
52e0: 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 condition->list
52f0: 65 78 6e 29 29 0a 09 09 09 09 20 20 20 20 20 20 exn)).....
5300: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 73 (delete-file* s
5310: 65 72 76 69 6e 66 6f 66 69 6c 65 29 29 0a 09 09 ervinfofile))...
5320: 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
5330: 64 72 20 73 65 72 76 72 73 29 20 70 72 69 6d 65 dr servrs) prime
5340: 2d 68 6f 73 74 20 72 65 73 75 6c 74 29 29 29 29 -host result))))
5350: 29 0a 09 09 09 20 20 20 20 20 28 65 6c 73 65 0a ).... (else.
5360: 09 09 09 20 20 20 20 20 20 3b 3b 20 63 61 6e 27 ... ;; can'
5370: 74 20 64 65 6c 65 74 65 20 69 74 20 61 73 20 77 t delete it as w
5380: 65 20 64 6f 6e 27 74 20 68 61 76 65 20 61 20 66 e don't have a f
5390: 69 6c 65 6e 61 6d 65 2e 20 4e 4f 54 45 3a 20 53 ilename. NOTE: S
53a0: 68 6f 75 6c 64 20 72 65 61 6c 6c 79 20 6e 65 76 hould really nev
53b0: 65 72 20 67 65 74 20 68 65 72 65 2e 0a 09 09 09 er get here.....
53c0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
53d0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
53e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
53f0: 52 4f 52 3a 20 62 61 64 20 73 65 72 76 69 6e 66 ROR: bad servinf
5400: 6f 20 72 65 63 6f 72 64 20 5c 22 22 73 65 72 76 o record \""serv
5410: 64 61 74 22 5c 22 22 29 0a 09 09 09 20 20 20 20 dat"\"")....
5420: 20 20 28 6c 6f 6f 70 20 28 63 64 72 20 73 65 72 (loop (cdr ser
5430: 76 72 73 29 20 70 72 69 6d 65 2d 68 6f 73 74 20 vrs) prime-host
5440: 72 65 73 75 6c 74 29 29 20 3b 3b 20 64 72 6f 70 result)) ;; drop
5450: 20 0a 09 09 09 20 20 20 20 20 29 29 29 29 29 0a .... ))))).
5460: 09 20 20 20 20 20 20 20 28 68 6f 6d 65 2d 68 6f . (home-ho
5470: 73 74 20 28 69 66 20 28 6e 75 6c 6c 3f 20 67 6f st (if (null? go
5480: 6f 64 2d 73 72 76 72 73 29 0a 09 09 09 20 20 20 od-srvrs)....
5490: 20 20 20 23 66 0a 09 09 09 20 20 20 20 20 20 28 #f.... (
54a0: 63 61 61 72 20 67 6f 6f 64 2d 73 72 76 72 73 29 caar good-srvrs)
54b0: 29 29 29 0a 09 20 20 3b 3b 20 62 79 20 68 65 72 ))).. ;; by her
54c0: 65 20 77 65 20 68 61 76 65 20 61 20 74 72 75 73 e we have a trus
54d0: 74 77 6f 72 74 68 79 20 6c 69 73 74 20 6f 66 20 tworthy list of
54e0: 73 65 72 76 65 72 73 20 61 6e 64 20 77 65 20 68 servers and we h
54f0: 61 76 65 20 72 65 6d 6f 76 65 64 20 74 68 65 20 ave removed the
5500: 2e 73 65 72 76 69 6e 66 6f 20 66 69 6c 65 20 66 .servinfo file f
5510: 6f 72 20 61 6e 79 20 75 6e 72 65 73 70 6f 6e 73 or any unrespons
5520: 69 76 65 20 73 65 72 76 65 72 73 0a 09 20 20 3b ive servers.. ;
5530: 3b 20 61 6e 64 20 74 68 65 20 6c 69 73 74 20 69 ; and the list i
5540: 73 20 69 6e 20 67 6f 6f 64 2d 73 72 76 72 73 0a s in good-srvrs.
5550: 09 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 6e . (cond.. ((n
5560: 6f 74 20 68 6f 6d 65 2d 68 6f 73 74 29 20 3b 3b ot home-host) ;;
5570: 20 6e 6f 20 73 65 72 76 65 72 73 20 79 65 74 2c no servers yet,
5580: 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 73 74 go ahead and st
5590: 61 72 74 0a 09 20 20 20 20 28 64 65 62 75 67 3a art.. (debug:
55a0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
55b0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
55c0: 22 4e 6f 20 73 65 72 76 65 72 73 20 79 65 74 2c "No servers yet,
55d0: 20 73 74 61 72 74 69 6e 67 20 6f 6e 20 22 28 67 starting on "(g
55e0: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 0a et-host-name))).
55f0: 09 20 20 20 28 28 3e 20 28 6c 65 6e 67 74 68 20 . ((> (length
5600: 67 6f 6f 64 2d 73 72 76 72 73 29 20 32 29 20 3b good-srvrs) 2) ;
5610: 3b 20 64 6f 6e 27 74 20 6e 65 65 64 20 6d 6f 72 ; don't need mor
5620: 65 2c 20 6a 75 73 74 20 65 78 69 74 0a 09 20 20 e, just exit..
5630: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
5640: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
5650: 6f 67 2d 70 6f 72 74 2a 20 22 48 61 76 65 20 22 og-port* "Have "
5660: 28 6c 65 6e 67 74 68 20 67 6f 6f 64 2d 73 72 76 (length good-srv
5670: 72 73 29 22 2c 20 6e 6f 20 6e 65 65 64 20 66 6f rs)", no need fo
5680: 72 20 6d 6f 72 65 2c 20 65 78 69 74 69 6e 67 2e r more, exiting.
5690: 22 29 0a 09 20 20 20 20 28 65 78 69 74 29 29 0a ").. (exit)).
56a0: 09 20 20 20 28 28 6e 6f 74 20 28 65 71 75 61 6c . ((not (equal
56b0: 3f 20 68 6f 6d 65 2d 68 6f 73 74 20 28 67 65 74 ? home-host (get
56c0: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 20 3b 3b -host-name))) ;;
56d0: 20 74 68 65 72 65 20 69 73 20 61 20 68 6f 6d 65 there is a home
56e0: 2d 68 6f 73 74 20 61 6e 64 20 77 65 20 61 72 65 -host and we are
56f0: 20 6e 6f 74 20 6f 6e 20 69 74 0a 09 20 20 20 20 not on it..
5700: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5710: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
5720: 2d 70 6f 72 74 2a 20 22 50 72 69 6d 65 20 6d 61 -port* "Prime ma
5730: 69 6e 20 73 65 72 76 65 72 20 69 73 20 6f 6e 20 in server is on
5740: 68 6f 73 74 20 22 68 6f 6d 65 2d 68 6f 73 74 22 host "home-host"
5750: 2c 20 62 75 74 20 77 65 20 61 72 65 20 6f 6e 20 , but we are on
5760: 68 6f 73 74 20 22 28 67 65 74 2d 68 6f 73 74 2d host "(get-host-
5770: 6e 61 6d 65 29 22 2c 20 65 78 69 74 69 6e 67 2e name)", exiting.
5780: 22 29 0a 09 20 20 20 20 28 65 78 69 74 29 29 0a ").. (exit)).
5790: 09 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 28 . (else.. (
57a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
57b0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
57c0: 70 6f 72 74 2a 20 22 53 74 61 72 74 69 6e 67 20 port* "Starting
57d0: 6f 6e 20 68 6f 73 74 20 22 28 67 65 74 2d 68 6f on host "(get-ho
57e0: 73 74 2d 6e 61 6d 65 29 22 2c 20 61 6c 6f 6e 67 st-name)", along
57f0: 20 77 69 74 68 20 22 28 6c 65 6e 67 74 68 20 67 with "(length g
5800: 6f 6f 64 2d 73 72 76 72 73 29 22 20 6f 74 68 65 ood-srvrs)" othe
5810: 72 20 73 65 72 76 65 72 73 2e 22 29 29 29 0a 0a r servers.")))..
5820: 09 20 20 3b 3b 20 74 68 69 73 20 64 69 64 6e 27 . ;; this didn'
5830: 74 20 73 65 65 6d 20 74 6f 20 77 6f 72 6b 2c 20 t seem to work,
5840: 69 73 20 70 6f 72 74 20 6e 6f 74 20 61 76 61 69 is port not avai
5850: 6c 61 62 6c 65 20 79 65 74 3f 0a 09 20 20 28 6c lable yet?.. (l
5860: 65 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 et loop ((count
5870: 30 29 29 0a 09 20 20 20 20 28 69 66 20 28 74 74 0)).. (if (tt
5880: 2d 70 6f 72 74 20 74 74 64 61 74 29 0a 09 09 28 -port ttdat)...(
5890: 62 65 67 69 6e 0a 09 09 20 20 28 70 72 6f 63 69 begin... (proci
58a0: 6e 66 2d 70 6f 72 74 2d 73 65 74 21 20 2a 70 72 nf-port-set! *pr
58b0: 6f 63 69 6e 66 2a 20 28 74 74 2d 70 6f 72 74 20 ocinf* (tt-port
58c0: 74 74 64 61 74 29 29 0a 09 09 20 20 28 70 72 6f ttdat))... (pro
58d0: 63 69 6e 66 2d 64 62 6e 61 6d 65 2d 73 65 74 21 cinf-dbname-set!
58e0: 20 2a 70 72 6f 63 69 6e 66 2a 20 64 62 66 6e 61 *procinf* dbfna
58f0: 6d 65 29 0a 09 09 20 20 28 64 62 66 69 6c 65 3a me)... (dbfile:
5900: 77 69 74 68 2d 6e 6f 2d 73 79 6e 63 2d 64 62 0a with-no-sync-db.
5910: 09 09 20 20 20 6e 6f 73 79 6e 63 64 62 70 61 74 .. nosyncdbpat
5920: 68 0a 09 09 20 20 20 28 6c 61 6d 62 64 61 20 28 h... (lambda (
5930: 6e 73 64 62 29 0a 09 09 20 20 20 20 20 28 64 62 nsdb)... (db
5940: 66 69 6c 65 3a 69 6e 73 65 72 74 2d 6f 72 2d 75 file:insert-or-u
5950: 70 64 61 74 65 2d 70 72 6f 63 65 73 73 20 6e 73 pdate-process ns
5960: 64 62 20 2a 70 72 6f 63 69 6e 66 2a 29 29 29 29 db *procinf*))))
5970: 0a 09 09 28 69 66 20 28 3c 20 63 6f 75 6e 74 20 ...(if (< count
5980: 31 30 29 0a 09 09 20 20 20 20 28 62 65 67 69 6e 10)... (begin
5990: 0a 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 ... (thread
59a0: 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 09 -sleep! 0.25)...
59b0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 63 (loop (+ c
59c0: 6f 75 6e 74 20 31 29 29 29 0a 09 09 20 20 20 20 ount 1)))...
59d0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 (begin... (
59e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
59f0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5a00: 20 22 45 52 52 4f 52 3a 20 28 74 74 2d 70 6f 72 "ERROR: (tt-por
5a10: 74 20 74 74 64 61 74 29 20 6e 6f 20 70 6f 72 74 t ttdat) no port
5a20: 20 73 65 74 21 20 45 78 69 74 69 6e 67 2e 22 29 set! Exiting.")
5a30: 0a 09 09 20 20 20 20 20 20 28 65 78 69 74 29 29 ... (exit))
5a40: 29 29 29 0a 09 20 20 0a 09 20 20 3b 3b 20 63 72 ))).. .. ;; cr
5a50: 65 61 74 65 20 61 20 73 65 72 76 69 6e 66 6f 20 eate a servinfo
5a60: 66 69 6c 65 20 73 74 61 72 74 20 6b 65 65 70 2d file start keep-
5a70: 72 75 6e 6e 69 6e 67 0a 20 20 20 20 20 20 20 20 running.
5a80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
5a90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5aa0: 72 74 2a 20 22 43 72 65 61 74 69 6e 67 20 73 65 rt* "Creating se
5ab0: 72 76 69 6e 66 6f 20 66 69 6c 65 20 66 6f 72 20 rvinfo file for
5ac0: 22 20 64 62 66 6e 61 6d 65 29 0a 09 20 20 28 74 " dbfname).. (t
5ad0: 74 3a 63 72 65 61 74 65 2d 73 65 72 76 65 72 2d t:create-server-
5ae0: 72 65 67 69 73 74 72 61 74 69 6f 6e 2d 66 69 6c registration-fil
5af0: 65 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 e ttdat dbfname)
5b00: 0a 09 20 20 28 70 72 6f 63 69 6e 66 2d 73 74 61 .. (procinf-sta
5b10: 74 75 73 2d 73 65 74 21 20 2a 70 72 6f 63 69 6e tus-set! *procin
5b20: 66 2a 20 22 72 75 6e 6e 69 6e 67 22 29 0a 09 20 f* "running")..
5b30: 20 28 74 74 2d 73 74 61 74 65 2d 73 65 74 21 20 (tt-state-set!
5b40: 74 74 64 61 74 20 27 72 75 6e 6e 69 6e 67 29 0a ttdat 'running).
5b50: 09 20 20 28 64 62 66 69 6c 65 3a 77 69 74 68 2d . (dbfile:with-
5b60: 6e 6f 2d 73 79 6e 63 2d 64 62 0a 09 20 20 20 6e no-sync-db.. n
5b70: 6f 73 79 6e 63 64 62 70 61 74 68 0a 09 20 20 20 osyncdbpath..
5b80: 28 6c 61 6d 62 64 61 20 28 6e 73 64 62 29 0a 09 (lambda (nsdb)..
5b90: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 69 6e 73 (dbfile:ins
5ba0: 65 72 74 2d 6f 72 2d 75 70 64 61 74 65 2d 70 72 ert-or-update-pr
5bb0: 6f 63 65 73 73 20 6e 73 64 62 20 2a 70 72 6f 63 ocess nsdb *proc
5bc0: 69 6e 66 2a 29 29 29 0a 09 20 20 28 74 68 72 65 inf*))).. (thre
5bd0: 61 64 2d 73 74 61 72 74 21 20 72 75 6e 2d 74 68 ad-start! run-th
5be0: 72 65 61 64 29 0a 0a 09 20 20 28 74 68 72 65 61 read)... (threa
5bf0: 64 2d 6a 6f 69 6e 21 20 72 75 6e 2d 74 68 72 65 d-join! run-thre
5c00: 61 64 29 20 3b 3b 20 72 75 6e 20 74 68 72 65 61 ad) ;; run threa
5c10: 64 20 77 69 6c 6c 20 65 78 69 74 20 6f 6e 20 74 d will exit on t
5c20: 69 6d 65 6f 75 74 20 6f 72 20 6f 74 68 65 72 20 imeout or other
5c30: 63 6f 6e 64 69 74 69 6f 6e 73 0a 09 20 20 0a 09 conditions.. ..
5c40: 20 20 3b 3b 20 28 74 63 70 2d 63 6c 6f 73 65 20 ;; (tcp-close
5c50: 28 74 74 2d 73 6f 63 6b 65 74 20 74 74 64 61 74 (tt-socket ttdat
5c60: 29 29 20 3b 3b 20 63 6c 6f 73 65 20 75 70 20 70 )) ;; close up p
5c70: 6f 72 74 73 20 68 65 72 65 0a 0a 09 20 20 3b 3b orts here... ;;
5c80: 20 72 65 70 6c 61 63 65 20 77 69 74 68 20 63 61 replace with ca
5c90: 6c 6c 20 74 6f 20 28 64 62 66 69 6c 65 3a 73 65 ll to (dbfile:se
5ca0: 74 2d 70 72 6f 63 65 73 73 2d 64 6f 6e 65 20 6e t-process-done n
5cb0: 73 64 62 20 68 6f 73 74 20 70 69 64 20 72 65 61 sdb host pid rea
5cc0: 73 6f 6e 29 0a 09 20 20 28 70 72 6f 63 69 6e 66 son).. (procinf
5cd0: 2d 73 74 61 74 75 73 2d 73 65 74 21 20 2a 70 72 -status-set! *pr
5ce0: 6f 63 69 6e 66 2a 20 22 64 6f 6e 65 22 29 0a 09 ocinf* "done")..
5cf0: 20 20 28 70 72 6f 63 69 6e 66 2d 65 6e 64 2d 73 (procinf-end-s
5d00: 65 74 21 20 2a 70 72 6f 63 69 6e 66 2a 20 28 63 et! *procinf* (c
5d10: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
5d20: 0a 09 20 20 3b 3b 20 65 69 74 68 65 72 20 63 6f .. ;; either co
5d30: 6e 76 65 72 74 20 74 68 69 73 20 74 6f 20 75 73 nvert this to us
5d40: 65 20 73 65 74 2d 70 72 6f 63 65 73 73 2d 64 6f e set-process-do
5d50: 6e 65 20 6f 72 20 67 65 74 20 72 69 64 20 6f 66 ne or get rid of
5d60: 20 73 65 74 2d 70 72 6f 63 65 73 73 2d 64 6f 6e set-process-don
5d70: 65 0a 09 20 20 28 64 62 66 69 6c 65 3a 77 69 74 e.. (dbfile:wit
5d80: 68 2d 6e 6f 2d 73 79 6e 63 2d 64 62 0a 09 20 20 h-no-sync-db..
5d90: 20 6e 6f 73 79 6e 63 64 62 70 61 74 68 0a 09 20 nosyncdbpath..
5da0: 20 20 28 6c 61 6d 62 64 61 20 28 6e 73 64 62 29 (lambda (nsdb)
5db0: 0a 09 20 20 20 20 20 28 64 62 66 69 6c 65 3a 69 .. (dbfile:i
5dc0: 6e 73 65 72 74 2d 6f 72 2d 75 70 64 61 74 65 2d nsert-or-update-
5dd0: 70 72 6f 63 65 73 73 20 6e 73 64 62 20 2a 70 72 process nsdb *pr
5de0: 6f 63 69 6e 66 2a 29 29 29 0a 09 20 20 28 64 65 ocinf*))).. (de
5df0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
5e00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5e10: 45 78 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 Exiting now.")..
5e20: 20 20 28 65 78 69 74 29 29 29 29 29 29 0a 0a 28 (exit))))))..(
5e30: 64 65 66 69 6e 65 20 28 74 74 3a 6b 65 65 70 2d define (tt:keep-
5e40: 72 75 6e 6e 69 6e 67 20 74 74 64 61 74 20 64 62 running ttdat db
5e50: 66 6e 61 6d 65 20 64 62 73 74 72 75 63 74 29 0a fname dbstruct).
5e60: 20 20 0a 20 20 3b 3b 20 61 74 20 74 68 69 73 20 . ;; at this
5e70: 70 6f 69 6e 74 20 74 68 65 20 73 65 72 76 65 72 point the server
5e80: 20 69 73 20 72 75 6e 6e 69 6e 67 20 61 6e 64 20 is running and
5e90: 72 65 73 70 6f 6e 64 69 6e 67 20 74 6f 20 63 61 responding to ca
5ea0: 6c 6c 73 2c 20 77 65 20 6a 75 73 74 20 6d 6f 6e lls, we just mon
5eb0: 69 74 6f 72 0a 20 20 3b 3b 20 66 6f 72 20 64 62 itor. ;; for db
5ec0: 20 63 61 6c 6c 73 20 61 6e 64 20 65 78 69 74 20 calls and exit
5ed0: 69 66 20 74 68 65 72 65 20 61 72 65 20 6e 6f 6e if there are non
5ee0: 65 2e 0a 0a 20 20 3b 3b 20 69 66 20 49 20 61 6d e... ;; if I am
5ef0: 20 6e 6f 74 20 69 6e 20 74 68 65 20 66 69 72 73 not in the firs
5f00: 74 20 33 20 73 65 72 76 65 72 73 2c 20 65 78 69 t 3 servers, exi
5f10: 74 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 t. (let* ((star
5f20: 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d t-time (current-
5f30: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 seconds))). (
5f40: 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 20 20 20 20 let loop ().
5f50: 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 (let* ((server
5f60: 73 20 20 20 28 74 74 3a 67 65 74 2d 73 65 72 76 s (tt:get-serv
5f70: 65 72 2d 69 6e 66 6f 2d 73 6f 72 74 65 64 20 74 er-info-sorted t
5f80: 74 64 61 74 20 64 62 66 6e 61 6d 65 29 29 0a 09 tdat dbfname))..
5f90: 20 20 20 20 20 28 68 6f 6d 65 2d 68 6f 73 74 20 (home-host
5fa0: 28 69 66 20 28 6e 75 6c 6c 3f 20 73 65 72 76 65 (if (null? serve
5fb0: 72 73 29 0a 09 09 09 20 20 20 20 23 66 0a 09 09 rs).... #f...
5fc0: 09 20 20 20 20 28 63 61 61 72 20 73 65 72 76 65 . (caar serve
5fd0: 72 73 29 29 29 0a 09 20 20 20 20 20 28 6d 79 2d rs))).. (my-
5fe0: 69 6e 64 65 78 20 20 28 6c 69 73 74 2d 69 6e 64 index (list-ind
5ff0: 65 78 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 ex (lambda (x)..
6000: 09 09 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f ... (equal?
6010: 20 28 6c 69 73 74 2d 72 65 66 20 78 20 36 29 0a (list-ref x 6).
6020: 09 09 09 09 09 20 20 20 20 20 20 28 74 74 2d 73 ..... (tt-s
6030: 65 72 76 69 6e 66 2d 66 69 6c 65 20 74 74 64 61 ervinf-file ttda
6040: 74 29 29 29 0a 09 09 09 09 20 20 20 20 73 65 72 t)))..... ser
6050: 76 65 72 73 29 29 0a 09 20 20 20 20 20 28 6f 6b vers)).. (ok
6060: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 (cond..
6070: 09 09 20 20 28 28 6e 6f 74 20 28 6e 75 6d 62 65 .. ((not (numbe
6080: 72 3f 20 6d 79 2d 69 6e 64 65 78 29 29 0a 09 09 r? my-index))...
6090: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
60a0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
60b0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 62 61 port* "ERROR: ba
60c0: 64 20 73 65 72 76 65 72 20 64 61 74 61 20 69 6e d server data in
60d0: 20 22 73 65 72 76 65 72 73 22 2c 20 6d 69 67 68 "servers", migh
60e0: 74 20 62 65 20 64 75 65 20 74 6f 20 68 6f 73 74 t be due to host
60f0: 20 6d 69 73 63 6f 6e 66 69 67 75 72 61 74 69 6f misconfiguratio
6100: 6e 20 73 75 63 68 20 61 73 20 62 61 64 20 49 50 n such as bad IP
6110: 20 61 64 64 72 65 73 73 20 69 6e 20 2f 65 74 63 address in /etc
6120: 2f 68 6f 73 74 73 2e 22 29 0a 09 09 09 20 20 20 /hosts.")....
6130: 23 66 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 #f).... ((not
6140: 2a 73 65 72 76 65 72 2d 72 75 6e 2a 29 0a 09 09 *server-run*)...
6150: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
6160: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6170: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
6180: 72 65 63 65 69 76 65 64 20 61 20 73 74 6f 70 20 received a stop
6190: 73 65 72 76 65 72 20 66 72 6f 6d 20 63 6c 69 65 server from clie
61a0: 6e 74 20 62 79 20 72 65 6d 6f 74 65 20 72 65 71 nt by remote req
61b0: 75 65 73 74 2e 22 29 0a 09 09 09 20 20 20 23 66 uest.").... #f
61c0: 29 0a 09 09 09 20 20 28 28 6e 75 6c 6c 3f 20 73 ).... ((null? s
61d0: 65 72 76 65 72 73 29 0a 09 09 09 20 20 20 28 64 ervers).... (d
61e0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
61f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
6200: 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 73 65 72 "WARNING: no ser
6210: 76 69 6e 66 6f 20 66 69 6c 65 73 20 66 6f 75 6e vinfo files foun
6220: 64 2c 20 74 68 69 73 20 63 61 6e 6e 6f 74 20 62 d, this cannot b
6230: 65 2e 22 29 0a 09 09 09 20 20 20 23 66 29 20 3b e.").... #f) ;
6240: 3b 20 6e 6f 74 20 6f 6b 0a 09 09 09 20 20 28 28 ; not ok.... ((
6250: 3e 20 6d 79 2d 69 6e 64 65 78 20 32 29 0a 09 09 > my-index 2)...
6260: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
6270: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6280: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
6290: 74 68 65 72 65 20 61 72 65 20 6d 6f 72 65 20 74 there are more t
62a0: 68 61 6e 20 74 77 6f 20 73 65 72 76 65 72 73 20 han two servers
62b0: 61 68 65 61 64 20 6f 66 20 6d 65 2c 20 49 27 6d ahead of me, I'm
62c0: 20 6e 6f 74 20 6e 65 65 64 65 64 2c 20 65 78 69 not needed, exi
62d0: 74 69 6e 67 2e 22 29 0a 09 09 09 20 20 20 23 66 ting.").... #f
62e0: 29 20 3b 3b 20 6e 6f 74 20 6f 6b 20 74 6f 20 6e ) ;; not ok to n
62f0: 6f 74 20 62 65 20 69 6e 20 66 69 72 73 74 20 74 ot be in first t
6300: 68 72 65 65 0a 09 09 09 20 20 28 28 65 71 3f 20 hree.... ((eq?
6310: 28 74 74 2d 73 74 61 74 65 20 74 74 64 61 74 29 (tt-state ttdat)
6320: 20 27 72 75 6e 6e 69 6e 67 29 20 23 74 29 20 3b 'running) #t) ;
6330: 3b 20 77 65 20 61 72 65 20 67 6f 6f 64 20 74 6f ; we are good to
6340: 20 6b 65 65 70 20 67 6f 69 6e 67 0a 09 09 09 20 keep going....
6350: 20 28 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 ((> (- (current
6360: 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d -seconds) start-
6370: 74 69 6d 65 29 20 33 30 29 0a 09 09 09 20 20 20 time) 30)....
6380: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
6390: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
63a0: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6f 76 65 72 * "WARNING: over
63b0: 20 33 30 20 73 65 63 6f 6e 64 73 20 61 6e 64 20 30 seconds and
63c0: 6e 6f 74 20 79 65 74 20 69 6e 20 72 75 6e 6e 6e not yet in runnn
63d0: 69 6e 67 20 6d 6f 64 65 2e 20 45 78 69 74 69 6e ing mode. Exitin
63e0: 67 2e 22 29 0a 09 09 09 20 20 20 23 66 29 0a 09 g.").... #f)..
63f0: 09 09 20 20 28 65 6c 73 65 20 23 74 29 29 29 29 .. (else #t))))
6400: 0a 09 28 69 66 20 6f 6b 0a 09 20 20 20 20 28 74 ..(if ok.. (t
6410: 74 2d 6c 61 73 74 2d 61 63 63 65 73 73 2d 73 65 t-last-access-se
6420: 74 21 20 74 74 64 61 74 20 2a 64 62 2d 6c 61 73 t! ttdat *db-las
6430: 74 2d 61 63 63 65 73 73 2a 29 20 3b 3b 20 62 69 t-access*) ;; bi
6440: 74 20 73 69 6c 6c 79 2c 20 6a 75 73 74 20 75 73 t silly, just us
6450: 65 20 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 e db-last-access
6460: 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 .. (begin..
6470: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6480: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6490: 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 69 port* "Exiting i
64a0: 6d 6d 65 64 69 61 74 65 6c 79 22 29 0a 09 20 20 mmediately")..
64b0: 20 20 20 20 28 74 74 3a 73 68 75 74 64 6f 77 6e (tt:shutdown
64c0: 2d 73 65 72 76 65 72 20 74 74 64 61 74 29 0a 09 -server ttdat)..
64d0: 20 20 20 20 20 20 28 65 78 69 74 29 29 29 0a 0a (exit)))..
64e0: 09 28 6c 65 74 2a 20 28 28 6c 61 73 74 2d 75 70 .(let* ((last-up
64f0: 64 61 74 65 20 28 64 62 72 3a 64 62 73 74 72 75 date (dbr:dbstru
6500: 63 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 64 ct-last-update d
6510: 62 73 74 72 75 63 74 29 29 0a 09 20 20 20 20 20 bstruct))..
6520: 20 20 28 63 75 72 72 2d 73 65 63 73 20 20 20 28 (curr-secs (
6530: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
6540: 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 )).. (if (and (
6550: 65 71 3f 20 28 74 74 2d 73 74 61 74 65 20 74 74 eq? (tt-state tt
6560: 64 61 74 29 20 27 72 75 6e 6e 69 6e 67 29 0a 09 dat) 'running)..
6570: 09 20 20 20 28 3e 20 28 2d 20 63 75 72 72 2d 73 . (> (- curr-s
6580: 65 63 73 20 6c 61 73 74 2d 75 70 64 61 74 65 29 ecs last-update)
6590: 20 35 29 29 20 3b 3b 20 65 76 65 72 79 20 35 20 5)) ;; every 5
65a0: 73 65 63 6f 6e 64 73 20 75 70 64 61 74 65 20 74 seconds update t
65b0: 68 65 20 64 62 3f 0a 09 20 20 20 20 20 20 28 6c he db?.. (l
65c0: 65 74 2a 20 28 28 73 69 6e 66 6f 2d 66 69 6c 65 et* ((sinfo-file
65d0: 20 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 69 6c (tt-servinf-fil
65e0: 65 20 74 74 64 61 74 29 29 29 0a 09 09 3b 3b 20 e ttdat)))...;;
65f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
6600: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6610: 2a 20 22 49 4e 46 4f 3a 20 74 6f 75 63 68 69 6e * "INFO: touchin
6620: 67 20 22 73 69 6e 66 6f 2d 66 69 6c 65 29 0a 09 g "sinfo-file)..
6630: 09 28 73 65 74 21 20 28 66 69 6c 65 2d 6d 6f 64 .(set! (file-mod
6640: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 ification-time s
6650: 69 6e 66 6f 2d 66 69 6c 65 29 20 28 63 75 72 72 info-file) (curr
6660: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 ent-seconds))...
6670: 28 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 73 ((dbr:dbstruct-s
6680: 79 6e 63 2d 70 72 6f 63 20 64 62 73 74 72 75 63 ync-proc dbstruc
6690: 74 29 20 6c 61 73 74 2d 75 70 64 61 74 65 29 0a t) last-update).
66a0: 09 09 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d ..(dbr:dbstruct-
66b0: 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 65 74 21 last-update-set!
66c0: 20 64 62 73 74 72 75 63 74 20 63 75 72 72 2d 73 dbstruct curr-s
66d0: 65 63 73 29 29 29 29 0a 09 0a 09 28 69 66 20 28 ecs))))....(if (
66e0: 3c 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 < (- (current-se
66f0: 63 6f 6e 64 73 29 20 28 74 74 2d 6c 61 73 74 2d conds) (tt-last-
6700: 61 63 63 65 73 73 20 74 74 64 61 74 29 29 20 28 access ttdat)) (
6710: 74 74 2d 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 tt-server-timeou
6720: 74 2d 70 61 72 61 6d 29 29 0a 09 20 20 20 20 28 t-param)).. (
6730: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 74 68 begin.. (th
6740: 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 read-sleep! 5)..
6750: 20 20 20 20 20 20 28 6c 6f 6f 70 29 29 29 29 29 (loop)))))
6760: 0a 20 20 20 20 28 74 74 3a 73 68 75 74 64 6f 77 . (tt:shutdow
6770: 6e 2d 73 65 72 76 65 72 20 74 74 64 61 74 29 0a n-server ttdat).
6780: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6790: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
67a0: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 53 65 72 port* "INFO: Ser
67b0: 76 65 72 20 74 69 6d 65 64 20 6f 75 74 2c 20 65 ver timed out, e
67c0: 78 69 74 69 6e 67 20 66 72 6f 6d 20 74 74 3a 6b xiting from tt:k
67d0: 65 65 70 2d 72 75 6e 6e 69 6e 67 2e 22 29 29 29 eep-running.")))
67e0: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 73 ...(define (tt:s
67f0: 68 75 74 64 6f 77 6e 2d 73 65 72 76 65 72 20 74 hutdown-server t
6800: 74 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 tdat). (let* ((
6810: 68 6f 73 74 20 28 74 74 2d 68 6f 73 74 20 74 74 host (tt-host tt
6820: 64 61 74 29 29 0a 09 20 28 70 6f 72 74 20 28 74 dat)).. (port (t
6830: 74 2d 70 6f 72 74 20 74 74 64 61 74 29 29 0a 09 t-port ttdat))..
6840: 20 28 73 69 6e 66 20 28 74 74 2d 73 65 72 76 69 (sinf (tt-servi
6850: 6e 66 2d 66 69 6c 65 20 74 74 64 61 74 29 29 29 nf-file ttdat)))
6860: 0a 20 20 20 20 28 74 74 2d 73 74 61 74 65 2d 73 . (tt-state-s
6870: 65 74 21 20 74 74 64 61 74 20 27 73 68 75 74 64 et! ttdat 'shutd
6880: 6f 77 6e 29 0a 20 20 20 20 28 70 6f 72 74 6c 6f own). (portlo
6890: 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c gger:open-run-cl
68a0: 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 ose portlogger:s
68b0: 65 74 2d 70 6f 72 74 20 70 6f 72 74 20 22 72 65 et-port port "re
68c0: 6c 65 61 73 65 64 22 29 0a 20 20 20 20 28 69 66 leased"). (if
68d0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 (file-exists? s
68e0: 69 6e 66 29 0a 09 28 64 65 6c 65 74 65 2d 66 69 inf)..(delete-fi
68f0: 6c 65 2a 20 73 69 6e 66 29 29 0a 20 20 20 20 29 le* sinf)). )
6900: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 73 65 72 )..;; return ser
6910: 76 69 64 0a 3b 3b 20 73 69 64 65 2d 65 66 66 65 vid.;; side-effe
6920: 63 74 73 3a 0a 3b 3b 20 20 20 74 74 64 61 74 2d cts:.;; ttdat-
6930: 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 69 73 20 cleanup-proc is
6940: 70 6f 70 75 6c 61 74 65 64 20 77 69 74 68 20 66 populated with f
6950: 75 6e 63 74 69 6f 6e 20 74 6f 20 72 65 6d 6f 76 unction to remov
6960: 65 20 74 68 65 20 73 65 72 76 65 72 69 6e 66 6f e the serverinfo
6970: 20 66 69 6c 65 0a 28 64 65 66 69 6e 65 20 28 74 file.(define (t
6980: 74 3a 63 72 65 61 74 65 2d 73 65 72 76 65 72 2d t:create-server-
6990: 72 65 67 69 73 74 72 61 74 69 6f 6e 2d 66 69 6c registration-fil
69a0: 65 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 e ttdat dbfname)
69b0: 0a 20 20 28 6c 65 74 2a 20 28 28 61 72 65 61 70 . (let* ((areap
69c0: 61 74 68 20 28 74 74 2d 61 72 65 61 70 61 74 68 ath (tt-areapath
69d0: 20 74 74 64 61 74 29 29 0a 09 20 28 73 65 72 76 ttdat)).. (serv
69e0: 64 69 72 20 20 28 74 74 3a 67 65 74 2d 73 65 72 dir (tt:get-ser
69f0: 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 61 vinfo-dir areapa
6a00: 74 68 29 29 0a 09 20 28 68 6f 73 74 20 20 20 20 th)).. (host
6a10: 20 28 74 74 2d 68 6f 73 74 20 74 74 64 61 74 29 (tt-host ttdat)
6a20: 29 0a 09 20 28 70 6f 72 74 20 20 20 20 20 28 74 ).. (port (t
6a30: 74 2d 70 6f 72 74 20 74 74 64 61 74 29 29 0a 09 t-port ttdat))..
6a40: 20 28 73 65 72 76 69 6e 66 20 28 63 6f 6e 63 20 (servinf (conc
6a50: 73 65 72 76 64 69 72 22 2f 22 68 6f 73 74 22 3a servdir"/"host":
6a60: 22 70 6f 72 74 22 2d 22 28 63 75 72 72 65 6e 74 "port"-"(current
6a70: 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 3a 22 64 -process-id)":"d
6a80: 62 66 6e 61 6d 65 29 29 0a 09 20 28 73 65 72 76 bfname)).. (serv
6a90: 2d 69 64 20 28 74 74 3a 6d 6b 2d 73 69 67 6e 61 -id (tt:mk-signa
6aa0: 74 75 72 65 20 61 72 65 61 70 61 74 68 29 29 29 ture areapath)))
6ab0: 0a 20 20 20 20 28 61 73 73 65 72 74 20 28 61 6e . (assert (an
6ac0: 64 20 68 6f 73 74 20 70 6f 72 74 29 20 22 46 41 d host port) "FA
6ad0: 54 41 4c 3a 20 74 74 3a 63 72 65 61 74 65 2d 73 TAL: tt:create-s
6ae0: 65 72 76 65 72 2d 72 65 67 69 73 74 72 61 74 69 erver-registrati
6af0: 6f 6e 2d 66 69 6c 65 20 63 61 6c 6c 65 64 20 77 on-file called w
6b00: 69 74 68 20 6e 6f 20 63 6f 6e 6e 2c 20 64 62 66 ith no conn, dbf
6b10: 6e 61 6d 65 3d 22 64 62 66 6e 61 6d 65 29 0a 20 name="dbfname).
6b20: 20 20 20 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 (tt-servinf-f
6b30: 69 6c 65 2d 73 65 74 21 20 74 74 64 61 74 20 73 ile-set! ttdat s
6b40: 65 72 76 69 6e 66 29 0a 20 20 20 20 28 77 69 74 ervinf). (wit
6b50: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
6b60: 20 73 65 72 76 69 6e 66 0a 20 20 20 20 20 20 28 servinf. (
6b70: 6c 61 6d 62 64 61 20 28 29 0a 09 28 70 72 69 6e lambda ()..(prin
6b80: 74 20 22 53 45 52 56 45 52 20 53 54 41 52 54 45 t "SERVER STARTE
6b90: 44 3a 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 D: "host":"port"
6ba0: 20 41 54 20 22 28 63 75 72 72 65 6e 74 2d 73 65 AT "(current-se
6bb0: 63 6f 6e 64 73 29 22 20 73 65 72 76 65 72 2d 69 conds)" server-i
6bc0: 64 3a 20 22 73 65 72 76 2d 69 64 22 20 70 69 64 d: "serv-id" pid
6bd0: 3a 20 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 : "(current-proc
6be0: 65 73 73 2d 69 64 29 22 20 64 62 66 6e 61 6d 65 ess-id)" dbfname
6bf0: 3a 20 22 64 62 66 6e 61 6d 65 29 29 29 0a 20 20 : "dbfname))).
6c00: 20 20 20 20 73 65 72 76 2d 69 64 29 29 0a 0a 3b serv-id))..;
6c10: 3b 20 66 69 6e 64 20 76 61 6c 69 64 20 73 65 72 ; find valid ser
6c20: 76 65 72 0a 3b 3b 20 67 65 74 20 73 65 72 76 65 ver.;; get serve
6c30: 72 73 20 6c 69 73 74 65 64 2c 20 6c 61 73 74 20 rs listed, last
6c40: 70 61 72 74 20 6f 66 20 6e 61 6d 65 20 6d 75 73 part of name mus
6c50: 74 20 6d 61 74 63 68 20 3a 3c 64 62 66 6e 61 6d t match :<dbfnam
6c60: 65 3e 0a 3b 3b 20 69 66 20 6d 6f 72 65 20 74 68 e>.;; if more th
6c70: 61 6e 20 6f 6e 65 2c 20 77 61 69 74 20 6f 6e 65 an one, wait one
6c80: 20 73 65 63 6f 6e 64 20 61 6e 64 20 6c 6f 6f 6b second and look
6c90: 20 61 67 61 69 6e 0a 3b 3b 20 66 75 74 75 72 65 again.;; future
6ca0: 3a 20 70 69 6e 67 20 6f 6c 64 65 73 74 2c 20 69 : ping oldest, i
6cb0: 66 20 61 6c 69 76 65 20 72 65 6d 6f 76 65 20 6f f alive remove o
6cc0: 74 68 65 72 20 3a 3c 64 62 66 6e 61 6d 65 3e 20 ther :<dbfname>
6cd0: 66 69 6c 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 files.;;.(define
6ce0: 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 72 (tt:find-server
6cf0: 20 61 72 65 61 70 61 74 68 20 64 62 66 6e 61 6d areapath dbfnam
6d00: 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 e). (let* ((ser
6d10: 76 64 69 72 20 20 28 74 74 3a 67 65 74 2d 73 65 vdir (tt:get-se
6d20: 72 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 rvinfo-dir areap
6d30: 61 74 68 29 29 0a 09 20 28 73 66 69 6c 65 73 20 ath)).. (sfiles
6d40: 20 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 73 65 (glob (conc se
6d50: 72 76 64 69 72 22 2f 2a 3a 22 64 62 66 6e 61 6d rvdir"/*:"dbfnam
6d60: 65 29 29 29 0a 09 20 28 67 6f 6f 64 66 69 6c 65 e))).. (goodfile
6d70: 73 20 27 28 29 29 29 0a 0a 20 20 20 20 3b 3b 20 s '())).. ;;
6d80: 66 69 6c 74 65 72 20 74 68 65 20 66 69 6c 65 73 filter the files
6d90: 20 68 65 72 65 20 62 79 20 6c 6f 6f 6b 69 6e 67 here by looking
6da0: 20 69 6e 20 70 72 6f 63 65 73 73 65 73 20 74 61 in processes ta
6db0: 62 6c 65 20 28 69 66 20 77 65 20 61 72 65 20 6e ble (if we are n
6dc0: 6f 74 20 6d 61 69 6e 2e 64 62 29 0a 20 20 20 20 ot main.db).
6dd0: 3b 3b 20 61 6e 64 20 6f 72 20 6c 6f 6f 6b 20 61 ;; and or look a
6de0: 74 20 74 68 65 20 74 69 6d 65 20 73 74 61 6d 70 t the time stamp
6df0: 20 6f 6e 20 74 68 65 20 73 65 72 76 69 6e 66 6f on the servinfo
6e00: 20 66 69 6c 65 2c 20 61 20 72 75 6e 6e 69 6e 67 file, a running
6e10: 20 73 65 72 76 65 72 20 77 69 6c 6c 0a 20 20 20 server will.
6e20: 20 3b 3b 20 74 6f 75 63 68 20 74 68 65 20 66 69 ;; touch the fi
6e30: 6c 65 20 65 76 65 72 79 20 6d 69 6e 75 74 65 20 le every minute
6e40: 28 61 67 61 69 6e 2c 20 74 68 69 73 20 77 69 6c (again, this wil
6e50: 6c 20 6f 6e 6c 79 20 61 70 70 6c 79 20 66 6f 72 l only apply for
6e60: 20 6d 61 69 6e 2e 64 62 29 0a 20 20 20 20 28 66 main.db). (f
6e70: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
6e80: 28 66 6e 61 6d 65 29 0a 09 09 28 6c 65 74 2a 20 (fname)...(let*
6e90: 28 28 61 67 65 20 28 2d 20 28 63 75 72 72 65 6e ((age (- (curren
6ea0: 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d t-seconds)(file-
6eb0: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
6ec0: 65 20 66 6e 61 6d 65 29 29 29 29 0a 09 09 20 20 e fname))))...
6ed0: 28 69 66 20 28 3e 20 61 67 65 20 32 30 30 29 20 (if (> age 200)
6ee0: 3b 3b 20 63 61 6e 27 74 20 74 72 75 73 74 20 69 ;; can't trust i
6ef0: 74 20 69 66 20 6f 76 65 72 20 32 30 30 20 73 65 t if over 200 se
6f00: 63 6f 6e 64 73 20 6f 6c 64 0a 09 09 20 20 20 20 conds old...
6f10: 20 20 28 62 65 67 69 6e 0a 09 09 09 28 64 65 62 (begin....(deb
6f20: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
6f30: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
6f40: 41 52 4e 49 4e 47 3a 20 72 65 6d 6f 76 69 6e 67 ARNING: removing
6f50: 20 73 74 61 6c 65 20 73 65 72 76 69 6e 66 6f 20 stale servinfo
6f60: 66 69 6c 65 20 22 66 6e 61 6d 65 22 2c 20 69 74 file "fname", it
6f70: 20 69 73 20 22 61 67 65 22 20 73 65 63 6f 6e 64 is "age" second
6f80: 73 20 6f 6c 64 22 29 0a 09 09 09 28 68 61 6e 64 s old")....(hand
6f90: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
6fa0: 09 20 65 78 6e 0a 09 09 09 20 28 64 65 62 75 67 . exn.... (debug
6fb0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
6fc0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
6fd0: 4e 49 4e 47 3a 20 65 72 72 6f 72 20 61 74 74 65 NING: error atte
6fe0: 6d 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 mpting to remove
6ff0: 20 73 74 61 6c 65 20 73 65 72 76 69 6e 66 6f 20 stale servinfo
7000: 66 69 6c 65 20 22 66 6e 61 6d 65 29 0a 09 09 09 file "fname)....
7010: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 66 6e (delete-file fn
7020: 61 6d 65 29 29 29 20 3b 3b 20 0a 09 09 20 20 20 ame))) ;; ...
7030: 20 20 20 28 73 65 74 21 20 67 6f 6f 64 66 69 6c (set! goodfil
7040: 65 73 20 28 63 6f 6e 73 20 66 6e 61 6d 65 20 67 es (cons fname g
7050: 6f 6f 64 66 69 6c 65 73 29 29 29 29 29 0a 09 20 oodfiles)))))..
7060: 20 20 20 20 20 73 66 69 6c 65 73 29 0a 20 20 20 sfiles).
7070: 20 67 6f 6f 64 66 69 6c 65 73 29 29 0a 0a 3b 3b goodfiles))..;;
7080: 20 67 69 76 65 6e 20 61 20 70 61 74 68 20 74 6f given a path to
7090: 20 61 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 a server info f
70a0: 69 6c 65 20 72 65 74 75 72 6e 3a 20 68 6f 73 74 ile return: host
70b0: 20 70 6f 72 74 20 73 74 61 72 74 73 65 63 6f 6e port startsecon
70c0: 64 73 20 73 65 72 76 65 72 2d 69 64 20 70 69 64 ds server-id pid
70d0: 20 64 62 66 6e 61 6d 65 20 6c 6f 67 66 0a 3b 3b dbfname logf.;;
70e0: 20 65 78 61 6d 70 6c 65 20 6f 66 20 77 68 61 74 example of what
70f0: 20 69 74 27 73 20 6c 6f 6f 6b 69 6e 67 20 66 6f it's looking fo
7100: 72 20 69 6e 20 74 68 65 20 6c 6f 67 20 66 69 6c r in the log fil
7110: 65 3a 0a 3b 3b 20 20 20 20 20 53 45 52 56 45 52 e:.;; SERVER
7120: 20 53 54 41 52 54 45 44 3a 20 31 30 2e 33 38 2e STARTED: 10.38.
7130: 31 37 35 2e 36 37 3a 35 30 32 31 36 20 41 54 20 175.67:50216 AT
7140: 31 36 31 36 35 30 32 33 35 30 2e 30 20 73 65 72 1616502350.0 ser
7150: 76 65 72 2d 69 64 3a 20 34 39 30 37 65 39 30 66 ver-id: 4907e90f
7160: 63 35 35 63 37 61 30 39 36 39 34 65 33 66 36 35 c55c7a09694e3f65
7170: 38 63 36 33 39 63 66 34 20 0a 3b 3b 0a 28 64 65 8c639cf4 .;;.(de
7180: 66 69 6e 65 20 28 74 74 3a 73 65 72 76 65 72 2d fine (tt:server-
7190: 67 65 74 2d 69 6e 66 6f 20 6c 6f 67 66 29 0a 20 get-info logf).
71a0: 20 28 6c 65 74 20 28 28 73 65 72 76 65 72 2d 72 (let ((server-r
71b0: 78 20 20 20 20 28 72 65 67 65 78 70 20 22 5e 53 x (regexp "^S
71c0: 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 28 ERVER STARTED: (
71d0: 5c 5c 53 2b 29 3a 28 5c 5c 64 2b 29 20 41 54 20 \\S+):(\\d+) AT
71e0: 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 20 73 65 72 76 ([\\d\\.]+) serv
71f0: 65 72 2d 69 64 3a 20 28 5c 5c 53 2b 29 20 70 69 er-id: (\\S+) pi
7200: 64 3a 20 28 5c 5c 64 2b 29 20 64 62 66 6e 61 6d d: (\\d+) dbfnam
7210: 65 3a 20 28 5c 5c 53 2b 29 22 29 29 20 3b 3b 20 e: (\\S+)")) ;;
7220: 53 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 SERVER STARTED:
7230: 68 6f 73 74 3a 70 6f 72 74 20 41 54 20 74 69 6d host:port AT tim
7240: 65 73 65 63 73 20 73 65 72 76 65 72 20 69 64 0a esecs server id.
7250: 20 20 20 20 20 20 20 20 28 64 62 70 72 65 70 2d (dbprep-
7260: 72 78 20 20 20 20 28 72 65 67 65 78 70 20 22 5e rx (regexp "^
7270: 53 45 52 56 45 52 3a 20 64 62 70 72 65 70 22 29 SERVER: dbprep")
7280: 29 0a 20 20 20 20 20 20 20 20 28 64 62 70 72 65 ). (dbpre
7290: 70 2d 66 6f 75 6e 64 20 30 29 0a 09 28 62 61 64 p-found 0)..(bad
72a0: 2d 64 61 74 20 20 20 20 20 20 28 6c 69 73 74 20 -dat (list
72b0: 23 66 20 23 66 20 23 66 20 23 66 20 23 66 20 23 #f #f #f #f #f #
72c0: 66 20 6c 6f 67 66 29 29 29 0a 20 20 20 20 20 28 f logf))). (
72d0: 6c 65 74 20 28 28 66 64 61 74 20 20 20 20 20 28 let ((fdat (
72e0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
72f0: 73 0a 09 09 09 20 65 78 6e 0a 09 09 20 20 20 20 s.... exn...
7300: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 3b 3b (begin.... ;;
7310: 20 42 55 47 2c 20 54 4f 44 4f 3a 20 61 64 64 20 BUG, TODO: add
7320: 65 72 72 20 63 68 65 63 6b 69 6e 67 2c 20 66 6f err checking, fo
7330: 72 20 6e 6f 77 20 62 6c 61 6e 6b 65 74 20 69 67 r now blanket ig
7340: 6e 6f 72 65 20 74 68 65 20 65 72 72 6f 72 73 3f nore the errors?
7350: 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
7360: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
7370: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 61 t-log-port* "Una
7380: 62 6c 65 20 74 6f 20 67 65 74 20 73 65 72 76 65 ble to get serve
7390: 72 20 69 6e 66 6f 20 66 72 6f 6d 20 22 6c 6f 67 r info from "log
73a0: 66 0a 09 09 09 09 09 20 20 20 22 2c 20 65 78 6e f...... ", exn
73b0: 3d 22 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 ="(condition->li
73c0: 73 74 20 65 78 6e 29 29 0a 09 09 09 20 27 28 29 st exn)).... '()
73d0: 29 20 3b 3b 20 6e 6f 20 69 64 65 61 20 77 68 61 ) ;; no idea wha
73e0: 74 20 77 65 6e 74 20 77 72 6f 6e 67 2c 20 63 61 t went wrong, ca
73f0: 6c 6c 20 69 74 20 61 20 62 61 64 20 73 65 72 76 ll it a bad serv
7400: 65 72 2c 20 72 65 74 75 72 6e 20 65 6d 70 74 79 er, return empty
7410: 20 6c 69 73 74 0a 09 09 20 20 20 20 20 20 20 28 list... (
7420: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
7430: 66 69 6c 65 20 6c 6f 67 66 20 72 65 61 64 2d 6c file logf read-l
7440: 69 6e 65 73 29 29 29 29 0a 20 20 20 20 20 20 20 ines)))).
7450: 28 69 66 20 28 6e 75 6c 6c 3f 20 66 64 61 74 29 (if (null? fdat)
7460: 20 3b 3b 20 62 61 64 20 64 61 74 61 2c 20 72 65 ;; bad data, re
7470: 74 75 72 6e 20 62 61 64 2d 64 61 74 0a 09 20 20 turn bad-dat..
7480: 20 62 61 64 2d 64 61 74 0a 09 20 20 20 28 6c 65 bad-dat.. (le
7490: 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 20 28 63 t loop ((inl (c
74a0: 61 72 20 66 64 61 74 29 29 0a 09 09 20 20 20 20 ar fdat))...
74b0: 20 20 28 74 61 69 6c 20 28 63 64 72 20 66 64 61 (tail (cdr fda
74c0: 74 29 29 0a 09 09 20 20 20 20 20 20 28 6c 6e 75 t))... (lnu
74d0: 6d 20 30 29 29 0a 09 20 20 20 20 20 28 6c 65 74 m 0)).. (let
74e0: 20 28 28 6d 6c 73 74 20 28 73 74 72 69 6e 67 2d ((mlst (string-
74f0: 6d 61 74 63 68 20 73 65 72 76 65 72 2d 72 78 20 match server-rx
7500: 69 6e 6c 29 29 0a 09 09 20 20 20 28 64 62 70 72 inl))... (dbpr
7510: 65 70 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ep (string-match
7520: 20 64 62 70 72 65 70 2d 72 78 20 69 6e 6c 29 29 dbprep-rx inl))
7530: 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 64 62 ).. (if db
7540: 70 72 65 70 20 28 73 65 74 21 20 64 62 70 72 65 prep (set! dbpre
7550: 70 2d 66 6f 75 6e 64 20 31 29 29 0a 09 20 20 20 p-found 1))..
7560: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6d 6c 73 (if (not mls
7570: 74 29 0a 09 09 20 20 20 28 69 66 20 28 3e 20 6c t)... (if (> l
7580: 6e 75 6d 20 35 30 30 29 20 3b 3b 20 67 69 76 65 num 500) ;; give
7590: 20 75 70 20 69 66 20 6d 6f 72 65 20 74 68 61 6e up if more than
75a0: 20 35 30 30 20 6c 69 6e 65 73 20 6f 66 20 73 65 500 lines of se
75b0: 72 76 65 72 20 6c 6f 67 20 72 65 61 64 0a 09 09 rver log read...
75c0: 20 20 20 20 20 20 20 62 61 64 2d 64 61 74 0a 09 bad-dat..
75d0: 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c . (if (nul
75e0: 6c 3f 20 74 61 69 6c 29 0a 09 09 09 20 20 20 62 l? tail).... b
75f0: 61 64 2d 64 61 74 0a 09 09 09 20 20 20 28 6c 6f ad-dat.... (lo
7600: 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 64 op (car tail)(cd
7610: 72 20 74 61 69 6c 29 28 2b 20 6c 6e 75 6d 20 31 r tail)(+ lnum 1
7620: 29 29 29 29 0a 09 09 20 20 20 28 6d 61 74 63 68 ))))... (match
7630: 20 6d 6c 73 74 20 3b 3b 20 68 61 76 65 20 61 20 mlst ;; have a
7640: 6e 6f 74 20 6e 75 6c 6c 20 6c 69 73 74 0a 09 09 not null list...
7650: 20 20 20 20 20 28 28 5f 20 68 6f 73 74 20 70 6f ((_ host po
7660: 72 74 20 73 74 61 72 74 20 73 65 72 76 65 72 2d rt start server-
7670: 69 64 20 70 69 64 20 64 62 66 6e 61 6d 65 29 0a id pid dbfname).
7680: 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 68 6f .. (list ho
7690: 73 74 0a 09 09 09 20 20 20 20 28 73 74 72 69 6e st.... (strin
76a0: 67 2d 3e 6e 75 6d 62 65 72 20 70 6f 72 74 29 0a g->number port).
76b0: 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e ... (string->
76c0: 6e 75 6d 62 65 72 20 73 74 61 72 74 29 0a 09 09 number start)...
76d0: 09 20 20 20 20 73 65 72 76 65 72 2d 69 64 0a 09 . server-id..
76e0: 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e .. (string->n
76f0: 75 6d 62 65 72 20 70 69 64 29 0a 09 09 09 20 20 umber pid)....
7700: 20 20 64 62 66 6e 61 6d 65 0a 09 09 09 20 20 20 dbfname....
7710: 20 6c 6f 67 66 29 29 0a 09 09 20 20 20 20 20 28 logf))... (
7720: 65 6c 73 65 0a 09 09 20 20 20 20 20 20 28 64 65 else... (de
7730: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
7740: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7750: 45 52 52 4f 52 3a 20 64 69 64 20 6e 6f 74 20 72 ERROR: did not r
7760: 65 63 6f 67 6e 69 73 65 20 53 45 52 56 45 52 20 ecognise SERVER
7770: 6c 69 6e 65 20 69 6e 66 6f 20 22 6d 6c 73 74 29 line info "mlst)
7780: 0a 09 09 20 20 20 20 20 20 62 61 64 2d 64 61 74 ... bad-dat
7790: 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 )))))))))..(defi
77a0: 6e 65 20 2a 6c 61 73 74 2d 73 65 72 76 65 72 2d ne *last-server-
77b0: 73 74 61 72 74 2a 20 28 6d 61 6b 65 2d 68 61 73 start* (make-has
77c0: 68 2d 74 61 62 6c 65 29 29 0a 0a 28 64 65 66 69 h-table))..(defi
77d0: 6e 65 20 28 74 74 3a 74 6f 6f 2d 72 65 63 65 6e ne (tt:too-recen
77e0: 74 2d 73 65 72 76 65 72 2d 73 74 61 72 74 20 64 t-server-start d
77f0: 62 66 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 bfname). (let*
7800: 28 28 6c 61 73 74 2d 72 75 6e 2d 74 69 6d 65 20 ((last-run-time
7810: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
7820: 64 65 66 61 75 6c 74 20 2a 6c 61 73 74 2d 73 65 default *last-se
7830: 72 76 65 72 2d 73 74 61 72 74 2a 20 64 62 66 6e rver-start* dbfn
7840: 61 6d 65 20 23 66 29 29 29 0a 20 20 20 20 28 61 ame #f))). (a
7850: 6e 64 20 6c 61 73 74 2d 72 75 6e 2d 74 69 6d 65 nd last-run-time
7860: 0a 09 20 28 3c 20 28 2d 20 28 63 75 72 72 65 6e .. (< (- (curren
7870: 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d t-seconds) last-
7880: 72 75 6e 2d 74 69 6d 65 29 20 35 29 29 29 29 0a run-time) 5)))).
7890: 20 20 20 20 0a 3b 3b 20 47 69 76 65 6e 20 61 6e .;; Given an
78a0: 20 61 72 65 61 20 70 61 74 68 2c 20 20 73 74 61 area path, sta
78b0: 72 74 20 61 20 73 65 72 76 65 72 20 70 72 6f 63 rt a server proc
78c0: 65 73 73 20 20 20 20 23 23 23 20 4e 4f 54 45 20 ess ### NOTE
78d0: 23 23 23 20 3e 20 66 69 6c 65 20 32 3e 26 31 20 ### > file 2>&1
78e0: 0a 3b 3b 20 69 66 20 74 68 65 20 74 61 72 67 65 .;; if the targe
78f0: 74 2d 68 6f 73 74 20 69 73 20 73 65 74 20 0a 3b t-host is set .;
7900: 3b 20 74 72 79 20 72 75 6e 6e 69 6e 67 20 6f 6e ; try running on
7910: 20 74 68 61 74 20 68 6f 73 74 0a 3b 3b 20 20 20 that host.;;
7920: 69 6e 63 69 64 65 6e 74 61 6c 3a 20 72 6f 74 61 incidental: rota
7930: 74 65 20 6c 6f 67 73 20 69 6e 20 6c 6f 67 73 2f te logs in logs/
7940: 20 64 69 72 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 dir..;;.(define
7950: 20 20 28 74 74 3a 73 65 72 76 65 72 2d 70 72 6f (tt:server-pro
7960: 63 65 73 73 2d 72 75 6e 20 61 72 65 61 70 61 74 cess-run areapat
7970: 68 20 74 65 73 74 73 75 69 74 65 20 6d 74 65 78 h testsuite mtex
7980: 65 20 72 75 6e 2d 69 64 20 23 21 6b 65 79 20 28 e run-id #!key (
7990: 70 72 6f 66 69 6c 65 2d 6d 6f 64 65 20 22 22 29 profile-mode "")
79a0: 29 20 3b 3b 20 61 72 65 61 70 61 74 68 20 69 73 ) ;; areapath is
79b0: 20 2a 74 6f 70 70 61 74 68 2a 20 66 6f 72 20 61 *toppath* for a
79c0: 20 67 69 76 65 6e 20 74 65 73 74 73 75 69 74 65 given testsuite
79d0: 20 61 72 65 61 0a 20 20 28 61 73 73 65 72 74 20 area. (assert
79e0: 61 72 65 61 70 61 74 68 20 20 22 46 41 54 41 4c areapath "FATAL
79f0: 3a 20 74 74 3a 73 65 72 76 65 72 2d 70 72 6f 63 : tt:server-proc
7a00: 65 73 73 2d 72 75 6e 20 63 61 6c 6c 65 64 20 77 ess-run called w
7a10: 69 74 68 6f 75 74 20 61 72 65 61 70 61 74 68 20 ithout areapath
7a20: 64 65 66 69 6e 65 64 2e 22 29 0a 20 20 28 61 73 defined."). (as
7a30: 73 65 72 74 20 74 65 73 74 73 75 69 74 65 20 22 sert testsuite "
7a40: 46 41 54 41 4c 3a 20 74 74 3a 73 65 72 76 65 72 FATAL: tt:server
7a50: 2d 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 61 6c -process-run cal
7a60: 6c 65 64 20 77 69 74 68 6f 75 74 20 74 65 73 74 led without test
7a70: 73 75 69 74 65 20 64 65 66 69 6e 65 64 2e 22 29 suite defined.")
7a80: 0a 20 20 28 61 73 73 65 72 74 20 6d 74 65 78 65 . (assert mtexe
7a90: 20 20 20 20 20 22 46 41 54 41 4c 3a 20 74 74 3a "FATAL: tt:
7aa0: 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 2d 72 server-process-r
7ab0: 75 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 6f 75 un called withou
7ac0: 74 20 6d 74 65 78 65 20 64 65 66 69 6e 65 64 2e t mtexe defined.
7ad0: 22 29 0a 20 20 3b 3b 20 6d 74 65 73 74 20 2d 73 "). ;; mtest -s
7ae0: 65 72 76 65 72 20 2d 20 2d 6d 20 74 65 73 74 73 erver - -m tests
7af0: 75 69 74 65 3a 65 78 74 2d 74 65 73 74 73 20 2d uite:ext-tests -
7b00: 64 62 20 36 2e 64 62 0a 20 20 28 6c 65 74 2a 20 db 6.db. (let*
7b10: 28 28 64 62 66 6e 61 6d 65 20 20 28 64 62 6d 6f ((dbfname (dbmo
7b20: 64 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 6e 61 6d d:run-id->dbfnam
7b30: 65 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 e run-id))).
7b40: 28 69 66 20 28 74 74 3a 74 6f 6f 2d 72 65 63 65 (if (tt:too-rece
7b50: 6e 74 2d 73 65 72 76 65 72 2d 73 74 61 72 74 20 nt-server-start
7b60: 64 62 66 6e 61 6d 65 29 0a 09 23 66 0a 09 28 6c dbfname)..#f..(l
7b70: 65 74 2a 20 28 28 6c 6f 61 64 20 20 20 20 20 28 et* ((load (
7b80: 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 get-normalized-c
7b90: 70 75 2d 6c 6f 61 64 29 29 0a 09 20 20 20 20 20 pu-load))..
7ba0: 20 20 28 73 72 76 72 73 20 20 20 20 28 74 74 3a (srvrs (tt:
7bb0: 66 69 6e 64 2d 73 65 72 76 65 72 20 61 72 65 61 find-server area
7bc0: 70 61 74 68 20 64 62 66 6e 61 6d 65 29 29 0a 09 path dbfname))..
7bd0: 20 20 20 20 20 20 20 28 74 72 79 69 6e 67 20 20 (trying
7be0: 20 28 6c 65 6e 67 74 68 20 73 72 76 72 73 29 29 (length srvrs))
7bf0: 0a 09 20 20 20 20 20 20 20 28 6e 72 75 6e 20 20 .. (nrun
7c00: 20 20 20 28 6e 75 6d 62 65 72 2d 6f 66 2d 70 72 (number-of-pr
7c10: 6f 63 65 73 73 65 73 2d 72 75 6e 6e 69 6e 67 20 ocesses-running
7c20: 28 63 6f 6e 63 20 22 6d 74 65 73 74 2e 2a 73 65 (conc "mtest.*se
7c30: 72 76 65 72 2e 2a 22 74 65 73 74 73 75 69 74 65 rver.*"testsuite
7c40: 22 2e 2a 22 64 62 66 6e 61 6d 65 29 29 29 29 0a ".*"dbfname)))).
7c50: 09 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 3e . (cond.. ((>
7c60: 20 6c 6f 61 64 20 32 2e 30 29 0a 09 20 20 20 20 load 2.0)..
7c70: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
7c80: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7c90: 2a 20 22 4e 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f * "Normalized lo
7ca0: 61 64 20 22 6c 6f 61 64 22 20 6f 6e 20 22 20 28 ad "load" on " (
7cb0: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 get-host-name) "
7cc0: 20 69 73 20 6f 76 65 72 20 74 68 65 20 6c 69 6d is over the lim
7cd0: 69 74 20 6f 66 20 32 2e 30 2e 20 4e 6f 74 20 73 it of 2.0. Not s
7ce0: 74 61 72 74 69 6e 67 20 61 20 73 65 72 76 65 72 tarting a server
7cf0: 2e 20 50 6c 65 61 73 65 20 72 65 64 75 63 65 20 . Please reduce
7d00: 74 68 65 20 6c 6f 61 64 20 6f 6e 20 22 28 67 65 the load on "(ge
7d10: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 22 20 62 79 t-host-name)" by
7d20: 20 6b 69 6c 6c 69 6e 67 20 73 6f 6d 65 20 70 72 killing some pr
7d30: 6f 63 65 73 73 65 73 22 29 0a 09 20 20 20 20 28 ocesses").. (
7d40: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
7d50: 0a 09 20 20 20 20 23 66 29 0a 09 20 20 20 28 28 .. #f).. ((
7d60: 3e 20 6e 72 75 6e 20 31 30 30 29 0a 09 20 20 20 > nrun 100)..
7d70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
7d80: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
7d90: 74 2a 20 6e 72 75 6e 22 20 73 65 72 76 65 72 73 t* nrun" servers
7da0: 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 22 20 28 67 running on " (g
7db0: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2c et-host-name) ",
7dc0: 20 6e 6f 74 20 73 74 61 72 74 69 6e 67 20 61 6e not starting an
7dd0: 6f 74 68 65 72 2e 22 29 0a 09 20 20 20 20 28 74 other.").. (t
7de0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
7df0: 09 20 20 20 20 23 66 29 0a 09 20 20 20 28 28 3e . #f).. ((>
7e00: 20 74 72 79 69 6e 67 20 32 29 0a 09 20 20 20 20 trying 2)..
7e10: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
7e20: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7e30: 2a 20 74 72 79 69 6e 67 22 20 73 65 72 76 65 72 * trying" server
7e40: 73 20 72 65 67 69 73 74 65 72 65 64 20 69 6e 20 s registered in
7e50: 2e 73 65 72 76 69 6e 66 6f 20 64 69 72 2e 20 6e .servinfo dir. n
7e60: 6f 74 20 73 74 61 72 74 69 6e 67 20 61 6e 6f 74 ot starting anot
7e70: 68 65 72 2e 22 29 0a 09 20 20 20 20 28 74 68 72 her.").. (thr
7e80: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 20 ead-sleep! 1)..
7e90: 20 20 20 23 66 29 0a 09 20 20 20 28 65 6c 73 65 #f).. (else
7ea0: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
7eb0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f file-exists? (co
7ec0: 6e 63 20 61 72 65 61 70 61 74 68 22 2f 6c 6f 67 nc areapath"/log
7ed0: 73 22 29 29 29 0a 09 09 28 63 72 65 61 74 65 2d s")))...(create-
7ee0: 64 69 72 65 63 74 6f 72 79 20 28 63 6f 6e 63 20 directory (conc
7ef0: 61 72 65 61 70 61 74 68 22 2f 6c 6f 67 73 22 29 areapath"/logs")
7f00: 20 23 74 29 29 0a 09 20 20 20 20 28 6c 65 74 2a #t)).. (let*
7f10: 20 28 28 6c 6f 67 66 69 6c 65 20 20 20 28 63 6f ((logfile (co
7f20: 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f 6c 6f nc areapath "/lo
7f30: 67 73 2f 73 65 72 76 65 72 2d 22 64 62 66 6e 61 gs/server-"dbfna
7f40: 6d 65 22 2d 22 28 63 75 72 72 65 6e 74 2d 70 72 me"-"(current-pr
7f50: 6f 63 65 73 73 2d 69 64 29 22 2e 6c 6f 67 22 29 ocess-id)".log")
7f60: 29 20 3b 3b 20 2d 22 20 63 75 72 72 2d 70 69 64 ) ;; -" curr-pid
7f70: 20 22 2d 22 20 74 61 72 67 65 74 2d 68 6f 73 74 "-" target-host
7f80: 20 22 2e 6c 6f 67 22 29 29 0a 09 09 20 20 20 28 ".log"))... (
7f90: 63 6d 64 6c 6e 20 28 63 6f 6e 63 0a 09 09 09 20 cmdln (conc....
7fa0: 20 20 20 20 20 20 6d 74 65 78 65 0a 09 09 09 20 mtexe....
7fb0: 20 20 20 20 20 20 22 20 2d 73 74 61 72 74 64 69 " -startdi
7fc0: 72 20 22 61 72 65 61 70 61 74 68 0a 09 09 09 20 r "areapath....
7fd0: 20 20 20 20 20 20 22 20 2d 73 65 72 76 65 72 20 " -server
7fe0: 2d 20 22 3b 3b 20 28 6f 72 20 74 61 72 67 65 74 - ";; (or target
7ff0: 2d 68 6f 73 74 20 22 2d 22 29 0a 09 09 09 20 20 -host "-")....
8000: 20 20 20 20 20 22 20 2d 6d 20 74 65 73 74 73 75 " -m testsu
8010: 69 74 65 3a 22 74 65 73 74 73 75 69 74 65 0a 09 ite:"testsuite..
8020: 09 09 20 20 20 20 20 20 20 22 20 2d 64 62 20 22 .. " -db "
8030: 64 62 66 6e 61 6d 65 20 3b 3b 20 28 64 62 6d 6f dbfname ;; (dbmo
8040: 64 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 6e 61 6d d:run-id->dbfnam
8050: 65 20 72 75 6e 2d 69 64 29 0a 09 09 09 20 20 20 e run-id)....
8060: 20 20 20 20 22 20 22 20 70 72 6f 66 69 6c 65 2d " " profile-
8070: 6d 6f 64 65 0a 09 09 09 20 20 20 20 20 20 20 23 mode.... #
8080: 3b 28 63 6f 6e 63 20 22 20 3e 3e 20 22 20 6c 6f ;(conc " >> " lo
8090: 67 66 69 6c 65 20 22 20 32 3e 26 31 20 26 22 29 gfile " 2>&1 &")
80a0: 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 77 65 ))).. ;; we
80b0: 20 77 61 6e 74 20 74 68 65 20 72 65 6d 6f 74 65 want the remote
80c0: 20 73 65 72 76 65 72 20 74 6f 20 73 74 61 72 74 server to start
80d0: 20 69 6e 20 2a 74 6f 70 70 61 74 68 2a 20 73 6f in *toppath* so
80e0: 20 70 75 73 68 20 74 68 65 72 65 0a 09 20 20 20 push there..
80f0: 20 20 20 3b 3b 20 28 70 75 73 68 2d 64 69 72 65 ;; (push-dire
8100: 63 74 6f 72 79 20 61 72 65 61 70 61 74 68 29 20 ctory areapath)
8110: 3b 3b 20 75 73 65 20 63 64 20 69 6e 20 74 68 65 ;; use cd in the
8120: 20 63 6f 6d 6d 61 6e 64 20 6c 69 6e 65 20 69 6e command line in
8130: 73 74 65 61 64 0a 09 20 20 20 20 20 20 28 64 65 stead.. (de
8140: 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 bug:print 2 *def
8150: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
8160: 49 4e 46 4f 3a 20 54 72 79 69 6e 67 20 74 6f 20 INFO: Trying to
8170: 73 74 61 72 74 20 73 65 72 76 65 72 20 69 6e 20 start server in
8180: 74 63 70 20 6d 6f 64 65 20 28 22 20 63 6d 64 6c tcp mode (" cmdl
8190: 6e 20 22 29 20 61 74 20 22 28 63 6f 6d 6d 6f 6e n ") at "(common
81a0: 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 22 20 66 6f :human-time)" fo
81b0: 72 20 22 61 72 65 61 70 61 74 68 29 0a 09 20 20 r "areapath)..
81c0: 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
81d0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
81e0: 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 og-port* "INFO:
81f0: 73 74 61 72 74 69 6e 67 20 73 65 72 76 65 72 20 starting server
8200: 61 74 20 22 20 28 63 6f 6d 6d 6f 6e 3a 68 75 6d at " (common:hum
8210: 61 6e 2d 74 69 6d 65 29 29 0a 0a 09 20 20 20 20 an-time))...
8220: 20 20 28 73 65 74 65 6e 76 20 22 4e 42 46 41 4b (setenv "NBFAK
8230: 45 5f 51 55 49 45 54 22 20 22 79 65 73 22 29 20 E_QUIET" "yes")
8240: 3b 3b 20 42 55 47 3a 20 63 68 61 6e 67 65 20 74 ;; BUG: change t
8250: 6f 20 77 69 74 68 2d 65 6e 76 69 72 6f 6e 6d 65 o with-environme
8260: 6e 74 2d 76 61 72 69 61 62 6c 65 20 2e 2e 2e 0a nt-variable ....
8270: 09 20 20 20 20 20 20 28 73 65 74 65 6e 76 20 22 . (setenv "
8280: 4e 42 46 41 4b 45 5f 4c 4f 47 22 20 6c 6f 67 66 NBFAKE_LOG" logf
8290: 69 6c 65 29 0a 09 20 20 20 20 20 20 28 73 79 73 ile).. (sys
82a0: 74 65 6d 20 28 63 6f 6e 63 20 22 63 64 20 22 61 tem (conc "cd "a
82b0: 72 65 61 70 61 74 68 22 20 3b 20 6e 62 66 61 6b reapath" ; nbfak
82c0: 65 20 22 20 63 6d 64 6c 6e 29 29 0a 09 20 20 20 e " cmdln))..
82d0: 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 4e 42 (unsetenv "NB
82e0: 46 41 4b 45 5f 51 55 49 45 54 22 29 0a 09 20 20 FAKE_QUIET")..
82f0: 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 4e (unsetenv "N
8300: 42 46 41 4b 45 5f 4c 4f 47 22 29 0a 09 20 20 20 BFAKE_LOG")..
8310: 20 20 20 3b 3b 20 28 73 79 73 74 65 6d 20 63 6d ;; (system cm
8320: 64 6c 6e 29 0a 09 20 20 20 20 20 20 28 68 61 73 dln).. (has
8330: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 6c 61 h-table-set! *la
8340: 73 74 2d 73 65 72 76 65 72 2d 73 74 61 72 74 2a st-server-start*
8350: 20 64 62 66 6e 61 6d 65 20 28 63 75 72 72 65 6e dbfname (curren
8360: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 t-seconds))..
8370: 20 20 20 3b 3b 20 3b 3b 20 75 73 65 20 62 65 6c ;; ;; use bel
8380: 6f 77 20 74 6f 20 67 6f 20 62 61 63 6b 20 74 6f ow to go back to
8390: 20 6e 62 66 61 6b 65 20 2d 20 6e 62 66 61 6b 65 nbfake - nbfake
83a0: 20 64 6f 65 73 20 63 61 75 73 65 20 74 72 6f 75 does cause trou
83b0: 62 6c 65 20 2e 2e 2e 0a 09 20 20 20 20 20 20 3b ble ..... ;
83c0: 3b 20 28 73 65 74 65 6e 76 20 22 4e 42 46 41 4b ; (setenv "NBFAK
83d0: 45 5f 51 55 49 45 54 22 20 22 79 65 73 22 29 20 E_QUIET" "yes")
83e0: 3b 3b 20 42 55 47 3a 20 63 68 61 6e 67 65 20 74 ;; BUG: change t
83f0: 6f 20 77 69 74 68 2d 65 6e 76 69 72 6f 6e 6d 65 o with-environme
8400: 6e 74 2d 76 61 72 69 61 62 6c 65 20 2e 2e 2e 0a nt-variable ....
8410: 09 20 20 20 20 20 20 3b 3b 20 28 73 65 74 65 6e . ;; (seten
8420: 76 20 22 4e 42 46 41 4b 45 5f 4c 4f 47 22 20 6c v "NBFAKE_LOG" l
8430: 6f 67 66 69 6c 65 29 0a 09 20 20 20 20 20 20 3b ogfile).. ;
8440: 3b 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 ; (system (conc
8450: 22 63 64 20 22 61 72 65 61 70 61 74 68 22 20 3b "cd "areapath" ;
8460: 20 6e 62 66 61 6b 65 20 22 20 63 6d 64 6c 6e 29 nbfake " cmdln)
8470: 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 75 6e 73 ).. ;; (uns
8480: 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 5f 51 55 etenv "NBFAKE_QU
8490: 49 45 54 22 29 0a 09 20 20 20 20 20 20 3b 3b 20 IET").. ;;
84a0: 28 75 6e 73 65 74 65 6e 76 20 22 4e 42 46 41 4b (unsetenv "NBFAK
84b0: 45 5f 4c 4f 47 22 29 0a 09 20 20 20 20 20 20 0a E_LOG").. .
84c0: 09 20 20 20 20 20 20 3b 3b 28 70 6f 70 2d 64 69 . ;;(pop-di
84d0: 72 65 63 74 6f 72 79 29 0a 09 20 20 20 20 20 20 rectory)..
84e0: 23 74 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d #t)))))))..;;===
84f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8530: 3d 3d 3d 0a 3b 3b 20 74 63 70 20 63 6f 6e 6e 65 ===.;; tcp conne
8540: 63 74 69 6f 6e 20 73 74 75 66 66 0a 3b 3b 3d 3d ction stuff.;;==
8550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8590: 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 6e 64 20 61 20 ====..;; find a
85a0: 70 6f 72 74 20 61 6e 64 20 73 74 61 72 74 20 74 port and start t
85b0: 63 70 2d 73 65 72 76 65 72 2e 20 54 68 69 73 20 cp-server. This
85c0: 6f 6e 6c 79 20 73 74 61 72 74 73 20 74 68 65 20 only starts the
85d0: 74 63 70 20 70 6f 72 74 69 6f 6e 20 6f 66 0a 3b tcp portion of.;
85e0: 3b 20 74 68 65 20 73 65 72 76 65 72 2c 20 6c 6f ; the server, lo
85f0: 6f 6b 20 61 74 20 28 74 74 3a 73 74 61 72 74 2d ok at (tt:start-
8600: 73 65 72 76 65 72 20 2e 2e 2e 29 20 61 62 6f 76 server ...) abov
8610: 65 20 66 6f 72 20 74 68 65 20 65 6e 74 72 79 20 e for the entry
8620: 70 6f 69 6e 74 0a 3b 3b 20 66 6f 72 20 74 68 65 point.;; for the
8630: 20 65 6e 74 69 72 65 20 73 65 72 76 65 72 20 73 entire server s
8640: 79 73 74 65 6d 0a 3b 3b 0a 28 64 65 66 69 6e 65 ystem.;;.(define
8650: 20 28 74 74 3a 73 74 61 72 74 2d 74 63 70 2d 73 (tt:start-tcp-s
8660: 65 72 76 65 72 20 74 74 64 61 74 29 0a 20 20 28 erver ttdat). (
8670: 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 2d 70 setup-listener-p
8680: 6f 72 74 6c 6f 67 67 65 72 20 74 74 64 61 74 29 ortlogger ttdat)
8690: 20 3b 3b 20 73 65 74 20 75 70 20 74 63 70 2d 6c ;; set up tcp-l
86a0: 69 73 74 65 6e 65 72 0a 20 20 28 6c 65 74 2a 20 istener. (let*
86b0: 28 28 73 6f 63 6b 65 74 20 20 20 28 74 74 2d 73 ((socket (tt-s
86c0: 6f 63 6b 65 74 20 20 74 74 64 61 74 29 29 0a 09 ocket ttdat))..
86d0: 20 28 68 61 6e 64 6c 65 72 20 20 28 74 74 2d 68 (handler (tt-h
86e0: 61 6e 64 6c 65 72 20 74 74 64 61 74 29 29 20 3b andler ttdat)) ;
86f0: 3b 20 74 68 65 20 68 61 6e 64 6c 65 72 20 63 6f ; the handler co
8700: 6d 65 73 20 66 72 6f 6d 20 6f 75 72 20 63 6c 69 mes from our cli
8710: 65 6e 74 20 73 65 74 74 69 6e 67 20 61 20 68 61 ent setting a ha
8720: 6e 64 6c 65 72 20 66 75 6e 63 74 69 6f 6e 0a 09 ndler function..
8730: 20 28 68 61 6e 64 6c 65 72 2d 70 72 6f 63 20 28 (handler-proc (
8740: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 28 6c lambda ().... (l
8750: 65 74 2a 20 28 28 69 6e 64 61 74 20 20 20 20 20 et* ((indat
8760: 20 20 20 20 28 64 65 73 65 72 69 61 6c 69 7a 65 (deserialize
8770: 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 3a )) ;; could use:
8780: 20 28 74 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 (thread-termina
8790: 74 65 21 20 28 63 75 72 72 65 6e 74 2d 74 68 72 te! (current-thr
87a0: 65 61 64 29 29 0a 09 09 09 09 28 72 65 73 75 6c ead)).....(resul
87b0: 74 20 20 20 20 20 20 20 20 23 66 29 0a 09 09 09 t #f)....
87c0: 09 28 65 78 6e 2d 72 65 73 75 6c 74 20 20 20 20 .(exn-result
87d0: 23 66 29 0a 09 09 09 09 28 73 74 64 6f 75 74 2d #f).....(stdout-
87e0: 72 65 73 75 6c 74 20 28 77 69 74 68 2d 6f 75 74 result (with-out
87f0: 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 09 09 put-to-string...
8800: 09 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a .... (lambda ().
8810: 09 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 ...... (let ((
8820: 72 65 73 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 res (handle-exce
8830: 70 74 69 6f 6e 73 0a 09 09 09 09 09 09 09 20 20 ptions........
8840: 20 20 20 20 20 65 78 6e 0a 09 09 09 09 09 09 09 exn........
8850: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 65 (let* ((e
8860: 72 72 64 61 74 20 28 63 6f 6e 64 69 74 69 6f 6e rrdat (condition
8870: 2d 3e 6c 69 73 74 20 65 78 6e 29 29 29 0a 09 09 ->list exn)))...
8880: 09 09 09 09 09 09 20 28 73 65 74 21 20 65 78 6e ...... (set! exn
8890: 2d 72 65 73 75 6c 74 20 65 72 72 64 61 74 29 0a -result errdat).
88a0: 09 09 09 09 09 09 09 09 20 28 64 65 62 75 67 3a ........ (debug:
88b0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
88c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
88d0: 52 3a 20 68 61 6e 64 6c 65 72 20 65 78 63 65 70 R: handler excep
88e0: 74 69 6f 6e 2c 20 74 68 65 73 65 20 61 72 65 20 tion, these are
88f0: 62 61 64 2c 20 77 69 6c 6c 20 65 78 69 74 20 69 bad, will exit i
8900: 6e 20 66 69 76 65 20 73 65 63 6f 6e 64 73 2e 22 n five seconds."
8910: 29 0a 09 09 09 09 09 09 09 09 20 28 70 70 20 65 )......... (pp e
8920: 72 72 64 61 74 20 2a 64 65 66 61 75 6c 74 2d 6c rrdat *default-l
8930: 6f 67 2d 70 6f 72 74 2a 29 0a 09 09 09 09 09 09 og-port*).......
8940: 09 09 20 3b 3b 20 74 68 65 73 65 20 61 72 65 20 .. ;; these are
8950: 61 6c 77 61 79 73 20 62 61 64 2c 20 73 65 74 20 always bad, set
8960: 75 70 20 61 6e 20 65 78 69 74 20 74 68 72 65 61 up an exit threa
8970: 64 0a 09 09 09 09 09 09 09 09 20 28 74 68 72 65 d......... (thre
8980: 61 64 2d 73 74 61 72 74 21 20 28 6d 61 6b 65 2d ad-start! (make-
8990: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
89a0: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 09 )........ .
89b0: 09 09 09 20 20 20 20 20 20 20 28 74 68 72 65 61 ... (threa
89c0: 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 09 09 09 d-sleep! 5).....
89d0: 09 09 09 20 20 20 20 20 20 09 09 09 09 20 20 20 ... ....
89e0: 20 20 20 20 28 65 78 69 74 29 29 29 29 0a 09 09 (exit))))...
89f0: 09 09 09 09 09 20 20 20 20 20 20 20 23 66 29 0a ..... #f).
8a00: 09 09 09 09 09 09 09 09 28 68 61 6e 64 6c 65 72 ........(handler
8a10: 20 69 6e 64 61 74 29 20 3b 3b 20 74 68 69 73 20 indat) ;; this
8a20: 69 73 20 74 68 65 20 70 72 6f 63 20 62 65 69 6e is the proc bein
8a30: 67 20 63 61 6c 6c 65 64 20 62 79 20 74 68 65 20 g called by the
8a40: 72 65 6d 6f 74 65 20 63 6c 69 65 6e 74 0a 09 09 remote client...
8a50: 09 09 09 09 09 09 29 29 29 0a 09 09 09 09 09 09 ......))).......
8a60: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 75 6c (set! resul
8a70: 74 20 72 65 73 29 29 29 29 29 0a 09 09 09 09 28 t res))))).....(
8a80: 66 75 6c 6c 2d 72 65 73 75 6c 74 20 20 20 20 28 full-result (
8a90: 6c 69 73 74 20 72 65 73 75 6c 74 20 65 78 6e 2d list result exn-
8aa0: 72 65 73 75 6c 74 20 28 69 66 20 28 65 71 75 61 result (if (equa
8ab0: 6c 3f 20 73 74 64 6f 75 74 2d 72 65 73 75 6c 74 l? stdout-result
8ac0: 20 22 22 29 20 23 66 20 73 74 64 6f 75 74 2d 72 "") #f stdout-r
8ad0: 65 73 75 6c 74 29 29 29 29 0a 09 09 09 20 20 20 esult))))....
8ae0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
8af0: 6e 73 0a 09 09 09 20 20 20 20 20 20 20 65 78 6e ns.... exn
8b00: 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a .... (begin.
8b10: 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
8b20: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
8b30: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 t-log-port* "Ser
8b40: 69 61 6c 69 7a 61 74 69 6f 6e 20 66 61 69 6c 75 ialization failu
8b50: 72 65 2e 20 66 75 6c 6c 2d 72 65 73 75 6c 74 3d re. full-result=
8b60: 22 66 75 6c 6c 2d 72 65 73 75 6c 74 29 0a 09 09 "full-result)...
8b70: 09 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d . (thread-
8b80: 73 74 61 72 74 21 20 28 6d 61 6b 65 2d 74 68 72 start! (make-thr
8b90: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 ead (lambda ()..
8ba0: 09 09 09 09 09 09 20 20 20 20 20 28 74 68 72 65 ...... (thre
8bb0: 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 09 09 ad-sleep! 5)....
8bc0: 09 09 09 09 20 20 20 20 20 28 65 78 69 74 29 29 .... (exit))
8bd0: 29 29 29 20 20 20 20 3b 3b 20 28 73 65 72 69 61 ))) ;; (seria
8be0: 6c 69 7a 65 20 27 28 23 66 20 23 66 20 23 66 29 lize '(#f #f #f)
8bf0: 29 20 3b 3b 20 64 6f 65 73 6e 27 74 20 77 6f 72 ) ;; doesn't wor
8c00: 6b 20 2d 20 74 68 65 20 66 69 72 73 74 20 63 61 k - the first ca
8c10: 6c 6c 20 74 6f 20 73 65 72 69 61 6c 69 7a 65 20 ll to serialize
8c20: 63 61 75 73 65 64 20 66 61 69 6c 75 72 65 0a 09 caused failure..
8c30: 09 09 20 20 20 20 20 28 73 65 72 69 61 6c 69 7a .. (serializ
8c40: 65 20 66 75 6c 6c 2d 72 65 73 75 6c 74 29 29 29 e full-result)))
8c50: 29 29 29 0a 20 20 20 20 28 28 6d 61 6b 65 2d 74 ))). ((make-t
8c60: 63 70 2d 73 65 72 76 65 72 20 73 6f 63 6b 65 74 cp-server socket
8c70: 20 68 61 6e 64 6c 65 72 2d 70 72 6f 63 29 0a 20 handler-proc).
8c80: 20 20 20 20 23 66 20 3b 3b 20 79 65 73 2c 20 73 #f ;; yes, s
8c90: 65 6e 64 20 65 72 72 6f 72 20 6d 65 73 73 61 67 end error messag
8ca0: 65 73 20 74 6f 20 73 74 64 2d 65 72 72 0a 20 20 es to std-err.
8cb0: 20 20 20 29 29 29 0a 0a 3b 3b 20 63 72 65 61 74 )))..;; creat
8cc0: 65 20 61 20 74 63 70 20 6c 69 73 74 65 6e 65 72 e a tcp listener
8cd0: 20 61 6e 64 20 72 65 74 75 72 6e 20 61 20 70 6f and return a po
8ce0: 70 75 6c 61 74 65 64 20 75 64 61 74 20 73 74 72 pulated udat str
8cf0: 75 63 74 20 77 69 74 68 0a 3b 3b 20 6d 79 20 70 uct with.;; my p
8d00: 6f 72 74 2c 20 61 64 64 72 65 73 73 2c 20 68 6f ort, address, ho
8d10: 73 74 6e 61 6d 65 2c 20 70 69 64 20 65 74 63 2e stname, pid etc.
8d20: 0a 3b 3b 20 72 65 74 75 72 6e 20 23 66 20 69 66 .;; return #f if
8d30: 20 66 61 69 6c 20 74 6f 20 66 69 6e 64 20 61 20 fail to find a
8d40: 70 6f 72 74 20 74 6f 20 61 6c 6c 6f 63 61 74 65 port to allocate
8d50: 2e 0a 3b 3b 0a 3b 3b 20 20 69 66 20 75 64 61 74 ..;;.;; if udat
8d60: 61 2d 69 6e 20 69 73 20 23 66 20 63 72 65 61 74 a-in is #f creat
8d70: 65 20 74 68 65 20 72 65 63 6f 72 64 0a 3b 3b 20 e the record.;;
8d80: 20 69 66 20 74 68 65 72 65 20 69 73 20 61 6c 72 if there is alr
8d90: 65 61 64 79 20 61 20 73 65 72 76 2d 6c 69 73 74 eady a serv-list
8da0: 65 6e 65 72 20 72 65 74 75 72 6e 20 74 68 65 20 ener return the
8db0: 75 64 61 74 61 0a 3b 3b 0a 3b 3b 20 28 64 65 66 udata.;;.;; (def
8dc0: 69 6e 65 20 28 73 65 74 75 70 2d 6c 69 73 74 65 ine (setup-liste
8dd0: 6e 65 72 20 75 63 6f 6e 6e 20 23 21 6f 70 74 69 ner uconn #!opti
8de0: 6f 6e 61 6c 20 28 70 6f 72 74 20 34 32 34 32 29 onal (port 4242)
8df0: 29 0a 3b 3b 20 20 20 28 61 73 73 65 72 74 20 28 ).;; (assert (
8e00: 74 74 3f 20 75 63 6f 6e 6e 29 20 22 46 41 54 41 tt? uconn) "FATA
8e10: 4c 3a 20 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 L: setup-listene
8e20: 72 20 63 61 6c 6c 65 64 20 77 69 74 68 20 77 72 r called with wr
8e30: 6f 6e 67 20 73 74 72 75 63 74 20 22 75 63 6f 6e ong struct "ucon
8e40: 6e 29 0a 3b 3b 20 20 20 28 68 61 6e 64 6c 65 2d n).;; (handle-
8e50: 65 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 exceptions.;;
8e60: 20 65 78 6e 0a 3b 3b 20 20 20 20 28 69 66 20 28 exn.;; (if (
8e70: 3c 20 70 6f 72 74 20 36 35 35 33 35 29 0a 3b 3b < port 65535).;;
8e80: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b (begin.;
8e90: 3b 20 09 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ; . (thread-slee
8ea0: 70 21 20 30 2e 32 35 29 0a 3b 3b 20 09 20 28 73 p! 0.25).;; . (s
8eb0: 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 75 63 etup-listener uc
8ec0: 6f 6e 6e 20 28 2b 20 70 6f 72 74 20 31 29 29 29 onn (+ port 1)))
8ed0: 0a 3b 3b 20 20 20 20 20 20 20 20 23 66 29 0a 3b .;; #f).;
8ee0: 3b 20 20 20 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 ; (connect-li
8ef0: 73 74 65 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 stener uconn por
8f00: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 t)))..(define (s
8f10: 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 2d 70 6f etup-listener-po
8f20: 72 74 6c 6f 67 67 65 72 20 75 63 6f 6e 6e 29 0a rtlogger uconn).
8f30: 20 20 28 6c 65 74 20 28 28 70 6f 72 74 20 28 70 (let ((port (p
8f40: 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 ortlogger:open-r
8f50: 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 un-close portlog
8f60: 67 65 72 3a 66 69 6e 64 2d 70 6f 72 74 29 29 29 ger:find-port)))
8f70: 0a 20 20 20 20 28 61 73 73 65 72 74 20 28 74 74 . (assert (tt
8f80: 3f 20 75 63 6f 6e 6e 29 20 22 46 41 54 41 4c 3a ? uconn) "FATAL:
8f90: 20 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 setup-listener
8fa0: 63 61 6c 6c 65 64 20 77 69 74 68 20 77 72 6f 6e called with wron
8fb0: 67 20 73 74 72 75 63 74 20 22 75 63 6f 6e 6e 29 g struct "uconn)
8fc0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
8fd0: 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 2 *default-log
8fe0: 2d 70 6f 72 74 2a 20 22 73 65 74 75 70 2d 6c 69 -port* "setup-li
8ff0: 73 74 65 6e 65 72 2d 70 6f 72 74 6c 6f 67 67 65 stener-portlogge
9000: 72 20 67 6f 74 20 70 6f 72 74 20 22 20 70 6f 72 r got port " por
9010: 74 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 t). (handle-e
9020: 78 63 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a 20 xceptions..exn.
9030: 20 20 20 20 20 28 69 66 20 28 3c 20 70 6f 72 74 (if (< port
9040: 20 36 35 35 33 35 29 0a 09 20 20 28 62 65 67 69 65535).. (begi
9050: 6e 0a 09 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 n.. (portlogg
9060: 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 er:open-run-clos
9070: 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 e portlogger:set
9080: 2d 66 61 69 6c 65 64 20 70 6f 72 74 29 0a 09 20 -failed port)..
9090: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
90a0: 21 20 30 2e 32 35 29 0a 09 20 20 20 20 28 73 65 ! 0.25).. (se
90b0: 74 75 70 2d 6c 69 73 74 65 6e 65 72 2d 70 6f 72 tup-listener-por
90c0: 74 6c 6f 67 67 65 72 20 75 63 6f 6e 6e 29 29 0a tlogger uconn)).
90d0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
90e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 . (de
90f0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
9100: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
9110: 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 2d 70 setup-listener-p
9120: 6f 72 74 6c 6f 67 67 65 72 3a 20 63 6f 75 6c 64 ortlogger: could
9130: 20 6e 6f 74 20 67 65 74 20 61 20 70 6f 72 74 22 not get a port"
9140: 29 0a 09 20 20 20 20 23 66 0a 20 20 20 20 20 20 ).. #f.
9150: 20 20 20 20 29 0a 20 20 20 20 20 20 29 0a 20 20 ). ).
9160: 20 20 20 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 (connect-lis
9170: 74 65 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 tener uconn port
9180: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
9190: 6f 6e 6e 65 63 74 2d 6c 69 73 74 65 6e 65 72 20 onnect-listener
91a0: 75 63 6f 6e 6e 20 70 6f 72 74 29 0a 20 20 3b 3b uconn port). ;;
91b0: 20 28 74 63 70 2d 6c 69 73 74 65 6e 65 72 2d 73 (tcp-listener-s
91c0: 6f 63 6b 65 74 20 4c 49 53 54 45 4e 45 52 29 28 ocket LISTENER)(
91d0: 73 6f 63 6b 65 74 2d 6e 61 6d 65 20 73 6f 29 0a socket-name so).
91e0: 20 20 3b 3b 20 73 6f 63 6b 61 64 64 72 2d 61 64 ;; sockaddr-ad
91f0: 64 72 65 73 73 2c 20 73 6f 63 6b 61 64 64 72 2d dress, sockaddr-
9200: 70 6f 72 74 2c 20 73 6f 63 6b 61 64 64 72 2d 3e port, sockaddr->
9210: 73 74 72 69 6e 67 0a 20 20 28 6c 65 74 2a 20 28 string. (let* (
9220: 28 74 6c 73 6e 20 28 74 63 70 2d 6c 69 73 74 65 (tlsn (tcp-liste
9230: 6e 20 70 6f 72 74 20 31 30 30 30 30 20 23 66 29 n port 10000 #f)
9240: 29 20 3b 3b 20 28 74 63 70 2d 6c 69 73 74 65 6e ) ;; (tcp-listen
9250: 20 54 43 50 50 4f 52 54 20 5b 42 41 43 4b 4c 4f TCPPORT [BACKLO
9260: 47 20 5b 48 4f 53 54 5d 5d 29 0a 09 20 28 61 64 G [HOST]]).. (ad
9270: 64 72 20 20 28 74 74 3a 67 65 74 2d 62 65 73 74 dr (tt:get-best
9280: 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 28 -guess-address (
9290: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 get-host-name)))
92a0: 29 20 3b 3b 20 28 67 65 74 2d 6d 79 2d 62 65 73 ) ;; (get-my-bes
92b0: 74 2d 61 64 64 72 65 73 73 29 29 29 20 3b 3b 20 t-address))) ;;
92c0: 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 (hostinfo-addres
92d0: 73 65 73 20 28 68 6f 73 74 2d 69 6e 66 6f 72 6d ses (host-inform
92e0: 61 74 69 6f 6e 20 28 63 75 72 72 65 6e 74 2d 68 ation (current-h
92f0: 6f 73 74 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 ostname))). (
9300: 74 74 2d 70 6f 72 74 2d 73 65 74 21 20 20 20 20 tt-port-set!
9310: 20 20 75 63 6f 6e 6e 20 70 6f 72 74 29 0a 20 20 uconn port).
9320: 20 20 28 74 74 2d 68 6f 73 74 2d 73 65 74 21 20 (tt-host-set!
9330: 20 20 20 20 20 75 63 6f 6e 6e 20 61 64 64 72 29 uconn addr)
9340: 0a 20 20 20 20 28 74 74 2d 68 6f 73 74 2d 70 6f . (tt-host-po
9350: 72 74 2d 73 65 74 21 20 75 63 6f 6e 6e 20 28 63 rt-set! uconn (c
9360: 6f 6e 63 20 61 64 64 72 22 3a 22 70 6f 72 74 29 onc addr":"port)
9370: 29 0a 20 20 20 20 28 74 74 2d 73 6f 63 6b 65 74 ). (tt-socket
9380: 2d 73 65 74 21 20 20 20 20 75 63 6f 6e 6e 20 74 -set! uconn t
9390: 6c 73 6e 29 0a 20 20 20 20 75 63 6f 6e 6e 29 29 lsn). uconn))
93a0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
93b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
93c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
93d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
93e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 75 74 ==========.;; ut
93f0: 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ils.;;==========
9400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
9440: 20 47 65 6e 65 72 61 74 65 20 61 20 75 6e 69 71 Generate a uniq
9450: 75 65 20 73 69 67 6e 61 74 75 72 65 20 66 6f 72 ue signature for
9460: 20 74 68 69 73 20 73 65 72 76 65 72 0a 28 64 65 this server.(de
9470: 66 69 6e 65 20 28 74 74 3a 6d 6b 2d 73 69 67 6e fine (tt:mk-sign
9480: 61 74 75 72 65 20 61 72 65 61 70 61 74 68 29 0a ature areapath).
9490: 20 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 (message-diges
94a0: 74 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 t-string (md5-pr
94b0: 69 6d 69 74 69 76 65 29 20 0a 09 09 09 20 28 77 imitive) .... (w
94c0: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 ith-output-to-st
94d0: 72 69 6e 67 0a 09 09 09 20 20 20 28 6c 61 6d 62 ring.... (lamb
94e0: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 77 da ().... (w
94f0: 72 69 74 65 20 28 6c 69 73 74 20 61 72 65 61 70 rite (list areap
9500: 61 74 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 ath.
9510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
9530: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
9540: 64 29 0a 09 09 09 09 09 20 20 28 61 72 67 76 29 d)...... (argv)
9550: 29 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 ))))))...(define
9560: 20 28 74 74 3a 67 65 74 2d 62 65 73 74 2d 67 75 (tt:get-best-gu
9570: 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 ess-address host
9580: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 name). (let ((r
9590: 65 73 20 23 66 29 29 0a 20 20 20 20 28 66 6f 72 es #f)). (for
95a0: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
95b0: 62 64 61 20 28 61 64 72 29 0a 20 20 20 20 20 20 bda (adr).
95c0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 (if (not (eq? (
95d0: 75 38 76 65 63 74 6f 72 2d 72 65 66 20 61 64 72 u8vector-ref adr
95e0: 20 30 29 20 31 32 37 29 29 0a 09 20 20 20 28 73 0) 127)).. (s
95f0: 65 74 21 20 72 65 73 20 61 64 72 29 29 29 0a 20 et! res adr))).
9600: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
9610: 73 20 63 61 6e 20 66 61 69 6c 20 77 68 65 6e 20 s can fail when
9620: 74 68 65 72 65 20 69 73 20 6e 6f 20 6d 65 6e 74 there is no ment
9630: 69 6f 6e 20 6f 66 20 74 68 65 20 68 6f 73 74 20 ion of the host
9640: 69 6e 20 2f 65 74 63 2f 68 6f 73 74 73 2e 20 46 in /etc/hosts. F
9650: 49 58 4d 45 0a 20 20 20 20 20 28 76 65 63 74 6f IXME. (vecto
9660: 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 69 6e 66 r->list (hostinf
9670: 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 o-addresses (hos
9680: 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 tname->hostinfo
9690: 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 20 hostname)))).
96a0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
96b0: 65 72 73 65 20 0a 20 20 20 20 20 28 6d 61 70 20 erse . (map
96c0: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 0a 09 number->string..
96d0: 20 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 (u8vector->lis
96e0: 74 0a 09 20 20 20 28 69 66 20 72 65 73 20 72 65 t.. (if res re
96f0: 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 s (hostname->ip
9700: 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 22 2e 22 hostname)))) "."
9710: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 )))..(define (tt
9720: 3a 67 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 :get-servinfo-di
9730: 72 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 6c r areapath). (l
9740: 65 74 2a 20 28 28 73 70 61 74 68 20 28 63 6f 6e et* ((spath (con
9750: 63 20 61 72 65 61 70 61 74 68 22 2f 2e 73 65 72 c areapath"/.ser
9760: 76 69 6e 66 6f 22 29 29 29 0a 20 20 20 20 28 69 vinfo"))). (i
9770: 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 f (not (file-exi
9780: 73 74 73 3f 20 73 70 61 74 68 29 29 0a 09 28 63 sts? spath))..(c
9790: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
97a0: 73 70 61 74 68 20 23 74 29 29 0a 20 20 20 20 73 spath #t)). s
97b0: 70 61 74 68 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d path))..;;======
97c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9800: 0a 3b 3b 20 6e 65 74 77 6f 72 6b 20 75 74 69 6c .;; network util
9810: 69 74 69 65 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ities.;;========
9820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
9860: 3b 3b 20 4e 4f 54 45 3a 20 4c 6f 6f 6b 20 61 74 ;; NOTE: Look at
9870: 20 61 64 64 72 65 73 73 2d 69 6e 66 6f 20 65 67 address-info eg
9880: 67 20 61 73 20 61 6c 74 65 72 6e 61 74 69 76 65 g as alternative
9890: 20 74 6f 20 73 6f 6d 65 20 6f 66 20 74 68 69 73 to some of this
98a0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 61 74 65 2d ..(define (rate-
98b0: 69 70 20 69 70 61 64 64 72 29 0a 20 20 28 72 65 ip ipaddr). (re
98c0: 67 65 78 2d 63 61 73 65 20 69 70 61 64 64 72 0a gex-case ipaddr.
98d0: 20 20 20 20 28 20 22 5e 31 32 37 5c 5c 2e 2e 2a ( "^127\\..*
98e0: 22 20 5f 20 30 20 29 0a 20 20 20 20 28 20 22 5e " _ 0 ). ( "^
98f0: 28 31 30 5c 5c 2e 30 7c 31 39 32 5c 5c 2e 31 36 (10\\.0|192\\.16
9900: 38 29 5c 5c 2e 2e 2a 22 20 5f 20 31 20 29 0a 20 8)\\..*" _ 1 ).
9910: 20 20 20 28 20 65 6c 73 65 20 32 20 29 20 29 29 ( else 2 ) ))
9920: 0a 0a 3b 3b 20 43 68 61 6e 67 65 20 74 68 69 73 ..;; Change this
9930: 20 74 6f 20 62 69 61 73 20 66 6f 72 20 61 64 64 to bias for add
9940: 72 65 73 73 65 73 20 77 69 74 68 20 61 20 72 65 resses with a re
9950: 61 73 6f 6e 61 62 6c 65 20 62 72 6f 61 64 63 61 asonable broadca
9960: 73 74 20 76 61 6c 75 65 3f 0a 3b 3b 0a 28 64 65 st value?.;;.(de
9970: 66 69 6e 65 20 28 69 70 2d 70 72 65 66 2d 6c 65 fine (ip-pref-le
9980: 73 73 3f 20 61 20 62 29 0a 20 20 28 3e 20 28 72 ss? a b). (> (r
9990: 61 74 65 2d 69 70 20 61 29 20 28 72 61 74 65 2d ate-ip a) (rate-
99a0: 69 70 20 62 29 29 29 0a 0a 28 64 65 66 69 6e 65 ip b)))..(define
99b0: 20 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 (get-my-best-ad
99c0: 64 72 65 73 73 29 0a 20 20 28 6c 65 74 20 28 28 dress). (let ((
99d0: 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 all-my-addresses
99e0: 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 29 29 (get-all-ips)))
99f0: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
9a00: 28 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 ((null? all-my-a
9a10: 64 64 72 65 73 73 65 73 29 0a 20 20 20 20 20 20 ddresses).
9a20: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
9a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a50: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 ;; no
9a60: 69 6e 74 65 72 66 61 63 65 73 3f 0a 20 20 20 20 interfaces?.
9a70: 20 28 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 61 ((eq? (length a
9a80: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 ll-my-addresses)
9a90: 20 31 29 0a 20 20 20 20 20 20 28 63 61 72 20 61 1). (car a
9aa0: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 ll-my-addresses)
9ab0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
9ac0: 20 20 20 20 20 20 20 3b 3b 20 6f 6e 6c 79 20 6f ;; only o
9ad0: 6e 65 20 74 6f 20 63 68 6f 6f 73 65 20 66 72 6f ne to choose fro
9ae0: 6d 2c 20 6a 75 73 74 20 67 6f 20 77 69 74 68 20 m, just go with
9af0: 69 74 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 it. (else.
9b00: 20 20 20 20 28 63 61 72 20 28 73 6f 72 74 20 61 (car (sort a
9b10: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 20 ll-my-addresses
9b20: 69 70 2d 70 72 65 66 2d 6c 65 73 73 3f 29 29 29 ip-pref-less?)))
9b30: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 )))..(define (ge
9b40: 74 2d 61 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 t-all-ips-sorted
9b50: 29 0a 20 20 28 73 6f 72 74 20 28 67 65 74 2d 61 ). (sort (get-a
9b60: 6c 6c 2d 69 70 73 29 20 69 70 2d 70 72 65 66 2d ll-ips) ip-pref-
9b70: 6c 65 73 73 3f 29 29 0a 0a 28 64 65 66 69 6e 65 less?))..(define
9b80: 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 0a 20 (get-all-ips).
9b90: 20 28 6d 61 70 20 61 64 64 72 65 73 73 2d 69 6e (map address-in
9ba0: 66 6f 2d 68 6f 73 74 0a 20 20 20 20 20 20 20 28 fo-host. (
9bb0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
9bc0: 78 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 61 x)... (equal? (a
9bd0: 64 64 72 65 73 73 2d 69 6e 66 6f 2d 74 79 70 65 ddress-info-type
9be0: 20 78 29 20 22 74 63 70 22 29 29 0a 09 20 20 20 x) "tcp"))..
9bf0: 20 20 20 20 28 61 64 64 72 65 73 73 2d 69 6e 66 (address-inf
9c00: 6f 73 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d os (get-host-nam
9c10: 65 29 29 29 29 29 0a 0a 29 0a e)))))..).