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 0a 28 75 73 65 20 tlogger))..(use
0430: 61 64 64 72 65 73 73 2d 69 6e 66 6f 20 74 63 70 address-info tcp
0440: 29 0a 0a 28 6d 6f 64 75 6c 65 20 74 63 70 2d 74 )..(module tcp-t
0450: 72 61 6e 73 70 6f 72 74 6d 6f 64 0a 09 2a 0a 09 ransportmod..*..
0460: 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 29 .(import scheme)
0470: 0a 0a 28 63 6f 6e 64 2d 65 78 70 61 6e 64 0a 20 ..(cond-expand.
0480: 28 63 68 69 63 6b 65 6e 2d 34 0a 20 20 28 69 6d (chicken-4. (im
0490: 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c port (prefix sql
04a0: 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 0a 09 ite3 sqlite3:)..
04b0: 20 20 63 68 69 63 6b 65 6e 0a 09 20 20 65 78 74 chicken.. ext
04c0: 72 61 73 0a 09 20 20 68 6f 73 74 69 6e 66 6f 0a ras.. hostinfo.
04d0: 0a 09 20 20 70 6f 72 74 73 0a 09 20 20 70 6f 73 .. ports.. pos
04e0: 69 78 0a 09 20 20 66 69 6c 65 73 0a 09 20 20 64 ix.. files.. d
04f0: 61 74 61 2d 73 74 72 75 63 74 75 72 65 73 0a 09 ata-structures..
0500: 20 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c directory-util
0510: 73 0a 09 20 20 74 63 70 0a 09 20 20 29 29 0a 20 s.. tcp.. )).
0520: 28 63 68 69 63 6b 65 6e 2d 35 0a 20 20 28 69 6d (chicken-5. (im
0530: 70 6f 72 74 20 63 68 69 63 6b 65 6e 2e 62 61 73 port chicken.bas
0540: 65 0a 09 20 20 63 68 69 63 6b 65 6e 2e 63 6f 6e e.. chicken.con
0550: 64 69 74 69 6f 6e 0a 09 20 20 63 68 69 63 6b 65 dition.. chicke
0560: 6e 2e 66 69 6c 65 0a 09 20 20 63 68 69 63 6b 65 n.file.. chicke
0570: 6e 2e 70 61 74 68 6e 61 6d 65 0a 09 20 20 63 68 n.pathname.. ch
0580: 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 2d 63 6f icken.process-co
0590: 6e 74 65 78 74 2e 70 6f 73 69 78 0a 09 20 20 63 ntext.posix.. c
05a0: 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 0a 09 hicken.process..
05b0: 20 20 63 68 69 63 6b 65 6e 2e 73 6f 72 74 0a 09 chicken.sort..
05c0: 20 20 63 68 69 63 6b 65 6e 2e 73 74 72 69 6e 67 chicken.string
05d0: 0a 09 20 20 63 68 69 63 6b 65 6e 2e 74 69 6d 65 .. chicken.time
05e0: 0a 09 20 20 63 68 69 63 6b 65 6e 2e 74 63 70 0a .. chicken.tcp.
05f0: 09 20 20 63 68 69 63 6b 65 6e 2e 72 61 6e 64 6f . chicken.rando
0600: 6d 0a 09 20 20 63 68 69 63 6b 65 6e 2e 66 69 6c m.. chicken.fil
0610: 65 2e 70 6f 73 69 78 0a 09 20 20 63 68 69 63 6b e.posix.. chick
0620: 65 6e 2e 70 72 65 74 74 79 2d 70 72 69 6e 74 0a en.pretty-print.
0630: 09 20 20 63 68 69 63 6b 65 6e 2e 69 6f 0a 09 20 . chicken.io..
0640: 20 63 68 69 63 6b 65 6e 2e 70 6f 72 74 0a 09 20 chicken.port..
0650: 20 63 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 chicken.process
0660: 2d 63 6f 6e 74 65 78 74 0a 0a 09 20 20 73 79 73 -context... sys
0670: 74 65 6d 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 29 tem-information)
0680: 0a 20 20 28 64 65 66 69 6e 65 20 75 6e 73 65 74 . (define unset
0690: 65 6e 76 20 75 6e 73 65 74 2d 65 6e 76 69 72 6f env unset-enviro
06a0: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 21 29 nment-variable!)
06b0: 0a 20 20 29 29 0a 20 0a 20 28 69 6d 70 6f 72 74 . )). . (import
06c0: 20 20 61 64 64 72 65 73 73 2d 69 6e 66 6f 0a 09 address-info..
06d0: 20 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c directory-util
06e0: 73 0a 09 20 20 6d 61 74 63 68 61 62 6c 65 0a 09 s.. matchable..
06f0: 20 20 6d 64 35 0a 09 20 20 6d 65 73 73 61 67 65 md5.. message
0700: 2d 64 69 67 65 73 74 0a 09 20 20 72 65 67 65 78 -digest.. regex
0710: 0a 09 20 20 72 65 67 65 78 2d 63 61 73 65 0a 09 .. regex-case..
0720: 20 20 73 31 31 6e 0a 09 20 20 73 72 66 69 2d 31 s11n.. srfi-1
0730: 0a 09 20 20 73 72 66 69 2d 31 38 0a 09 20 20 73 .. srfi-18.. s
0740: 72 66 69 2d 34 0a 09 20 20 73 72 66 69 2d 36 39 rfi-4.. srfi-69
0750: 0a 09 20 20 73 74 61 63 6b 0a 09 20 20 74 79 70 .. stack.. typ
0760: 65 64 2d 72 65 63 6f 72 64 73 0a 09 20 20 74 63 ed-records.. tc
0770: 70 2d 73 65 72 76 65 72 0a 09 20 20 0a 09 20 20 p-server.. ..
0780: 64 65 62 75 67 70 72 69 6e 74 0a 09 20 20 63 6f debugprint.. co
0790: 6d 6d 6f 6e 6d 6f 64 0a 09 20 20 64 62 66 69 6c mmonmod.. dbfil
07a0: 65 0a 09 20 20 64 62 6d 6f 64 0a 09 20 20 70 6f e.. dbmod.. po
07b0: 72 74 6c 6f 67 67 65 72 0a 09 29 0a 0a 3b 3b 3d rtlogger..)..;;=
07c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07e0: 3d 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 20 63 6c 69 65 6e 74 0a =====.;; client.
0810: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 0a 3b 3b 20 28 64 65 ========..;; (de
0860: 66 69 6e 65 20 6b 65 65 70 2d 61 67 65 2d 70 61 fine keep-age-pa
0870: 72 61 6d 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 ram (make-parame
0880: 74 65 72 20 31 30 29 29 20 3b 3b 20 71 69 66 20 ter 10)) ;; qif
0890: 66 69 6c 65 20 61 67 65 2c 20 69 66 20 6f 76 65 file age, if ove
08a0: 72 20 6d 6f 76 65 20 74 6f 20 61 74 74 69 63 0a r move to attic.
08b0: 0a 3b 3b 20 55 73 65 64 20 4f 4e 4c 59 20 66 6f .;; Used ONLY fo
08c0: 72 20 63 6c 69 65 6e 74 0a 3b 3b 0a 28 64 65 66 r client.;;.(def
08d0: 73 74 72 75 63 74 20 74 74 2d 63 6f 6e 6e 0a 20 struct tt-conn.
08e0: 20 68 6f 73 74 0a 20 20 70 6f 72 74 0a 20 20 68 host. port. h
08f0: 6f 73 74 2d 70 6f 72 74 0a 20 20 64 62 66 6e 61 ost-port. dbfna
0900: 6d 65 0a 20 20 73 65 72 76 65 72 2d 69 64 0a 20 me. server-id.
0910: 20 73 65 72 76 65 72 2d 73 74 61 72 74 0a 20 20 server-start.
0920: 73 65 72 76 69 6e 66 2d 66 69 6c 65 0a 20 20 70 servinf-file. p
0930: 69 64 0a 29 0a 0a 3b 3b 20 55 73 65 64 20 66 6f id.)..;; Used fo
0940: 72 20 42 4f 54 48 20 63 6c 69 65 6e 74 73 20 61 r BOTH clients a
0950: 6e 64 20 73 65 72 76 65 72 73 0a 28 64 65 66 73 nd servers.(defs
0960: 74 72 75 63 74 20 74 74 0a 20 20 3b 3b 20 63 6c truct tt. ;; cl
0970: 69 65 6e 74 20 72 65 6c 61 74 65 64 0a 20 20 28 ient related. (
0980: 63 6f 6e 6e 73 20 28 6d 61 6b 65 2d 68 61 73 68 conns (make-hash
0990: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 64 62 66 6e -table)) ;; dbfn
09a0: 61 6d 65 20 2d 3e 20 63 6f 6e 6e 0a 0a 20 20 3b ame -> conn.. ;
09b0: 3b 20 73 65 72 76 65 72 20 72 65 6c 61 74 65 64 ; server related
09c0: 0a 20 20 28 73 74 61 74 65 20 20 20 20 20 20 20 . (state
09d0: 20 27 73 74 61 72 74 69 6e 67 29 0a 20 20 28 61 'starting). (a
09e0: 72 65 61 70 61 74 68 20 20 20 20 20 23 66 29 0a reapath #f).
09f0: 20 20 28 68 6f 73 74 20 20 20 20 20 20 20 20 20 (host
0a00: 23 66 29 0a 20 20 28 70 6f 72 74 20 20 20 20 20 #f). (port
0a10: 20 20 20 20 23 66 29 0a 20 20 28 63 6f 6e 6e 20 #f). (conn
0a20: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 63 #f). (c
0a30: 6c 65 61 6e 75 70 2d 70 72 6f 63 20 23 66 29 0a leanup-proc #f).
0a40: 20 20 28 68 61 6e 64 6c 65 72 20 20 20 20 20 20 (handler
0a50: 23 66 29 20 3b 3b 20 72 65 63 65 69 76 65 73 20 #f) ;; receives
0a60: 64 61 74 61 20 61 6e 64 20 72 65 73 70 6f 6e 64 data and respond
0a70: 73 0a 20 20 28 73 6f 63 6b 65 74 20 20 20 20 20 s. (socket
0a80: 20 20 23 66 29 0a 20 20 28 74 68 72 65 61 64 20 #f). (thread
0a90: 20 20 20 20 20 20 23 66 29 0a 20 20 28 68 6f 73 #f). (hos
0aa0: 74 2d 70 6f 72 74 20 20 20 20 23 66 29 0a 20 20 t-port #f).
0ab0: 28 63 6d 64 2d 74 68 72 65 61 64 20 20 20 23 66 (cmd-thread #f
0ac0: 29 0a 20 20 28 72 6f 2d 6d 6f 64 65 20 20 20 20 ). (ro-mode
0ad0: 20 20 23 66 29 0a 20 20 28 72 6f 2d 6d 6f 64 65 #f). (ro-mode
0ae0: 2d 63 68 65 63 6b 65 64 20 23 66 29 0a 20 20 28 -checked #f). (
0af0: 6c 61 73 74 2d 61 63 63 65 73 73 20 20 28 63 75 last-access (cu
0b00: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
0b10: 20 20 28 73 65 72 76 69 6e 66 2d 66 69 6c 65 20 (servinf-file
0b20: 23 66 29 0a 20 20 28 6c 61 73 74 2d 73 65 72 76 #f). (last-serv
0b30: 2d 73 74 61 72 74 20 30 29 0a 20 20 29 0a 0a 3b -start 0). )..;
0b40: 3b 20 70 61 72 61 6d 65 74 65 72 73 0a 3b 3b 0a ; parameters.;;.
0b50: 28 64 65 66 69 6e 65 20 74 74 2d 73 65 72 76 65 (define tt-serve
0b60: 72 2d 74 69 6d 65 6f 75 74 2d 70 61 72 61 6d 20 r-timeout-param
0b70: 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 20 (make-parameter
0b80: 36 30 30 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 74 600))..;; make t
0b90: 74 64 61 74 20 76 69 73 69 62 6c 65 0a 28 64 65 tdat visible.(de
0ba0: 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 6e 66 fine *server-inf
0bb0: 6f 2a 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a o* #f).(define *
0bc0: 73 65 72 76 65 72 2d 72 75 6e 2a 20 20 23 74 29 server-run* #t)
0bd0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 6d 61 ..(define (tt:ma
0be0: 6b 65 2d 72 65 6d 6f 74 65 20 61 72 65 61 70 61 ke-remote areapa
0bf0: 74 68 29 0a 20 20 28 6d 61 6b 65 2d 74 74 20 61 th). (make-tt a
0c00: 72 65 61 70 61 74 68 3a 20 61 72 65 61 70 61 74 reapath: areapat
0c10: 68 29 29 0a 0a 3b 3b 20 31 20 2e 2e 2e 20 6f 72 h))..;; 1 ... or
0c20: 20 23 66 0a 3b 3b 20 61 6e 64 20 63 68 65 63 6b #f.;; and check
0c30: 20 74 68 61 74 20 64 62 66 6e 61 6d 65 20 6d 61 that dbfname ma
0c40: 74 63 68 65 73 2e 20 46 49 58 4d 45 3a 20 74 68 tches. FIXME: th
0c50: 65 20 70 72 6f 70 61 67 61 74 69 6f 6e 20 6f 66 e propagation of
0c60: 20 64 62 66 6e 61 6d 65 20 61 6e 64 20 72 75 6e dbfname and run
0c70: 2d 69 64 0a 3b 3b 20 6d 69 67 68 74 20 6e 6f 74 -id.;; might not
0c80: 20 6d 61 6b 65 20 74 68 65 20 62 65 73 74 20 73 make the best s
0c90: 65 6e 73 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ense.;;.(define
0ca0: 28 74 74 3a 76 61 6c 69 64 2d 72 75 6e 2d 69 64 (tt:valid-run-id
0cb0: 20 72 75 6e 2d 69 64 20 64 62 66 6e 61 6d 65 29 run-id dbfname)
0cc0: 0a 20 20 28 61 6e 64 20 28 6f 72 20 28 6e 75 6d . (and (or (num
0cd0: 62 65 72 3f 20 72 75 6e 2d 69 64 29 0a 09 20 20 ber? run-id)..
0ce0: 20 28 6e 6f 74 20 72 75 6e 2d 69 64 29 29 0a 20 (not run-id)).
0cf0: 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 64 (equal? (d
0d00: 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 bfile:run-id->db
0d10: 66 6e 61 6d 65 20 72 75 6e 2d 69 64 29 20 64 62 fname run-id) db
0d20: 66 6e 61 6d 65 29 29 29 0a 0a 28 74 63 70 2d 62 fname)))..(tcp-b
0d30: 75 66 66 65 72 2d 73 69 7a 65 20 32 30 34 38 29 uffer-size 2048)
0d40: 0a 3b 3b 20 28 6d 61 78 2d 63 6f 6e 6e 65 63 74 .;; (max-connect
0d50: 69 6f 6e 73 20 34 30 39 36 29 0a 0a 28 64 65 66 ions 4096)..(def
0d60: 69 6e 65 20 28 74 74 3a 67 65 74 2d 63 6f 6e 6e ine (tt:get-conn
0d70: 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 0a ttdat dbfname).
0d80: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
0d90: 66 2f 64 65 66 61 75 6c 74 20 28 74 74 2d 63 6f f/default (tt-co
0da0: 6e 6e 73 20 74 74 64 61 74 29 20 64 62 66 6e 61 nns ttdat) dbfna
0db0: 6d 65 20 23 66 29 29 0a 0a 3b 3b 20 64 6f 20 61 me #f))..;; do a
0dc0: 6c 6c 20 74 68 65 20 62 75 73 79 20 77 6f 72 6b ll the busy work
0dd0: 20 6f 66 20 66 69 6e 64 69 6e 67 20 61 6e 64 20 of finding and
0de0: 73 65 74 74 69 6e 67 20 75 70 20 63 6f 6e 6e 20 setting up conn
0df0: 66 6f 72 0a 3b 3b 20 63 6f 6e 6e 65 63 74 69 6e for.;; connectin
0e00: 67 20 74 6f 20 61 20 73 65 72 76 65 72 0a 3b 3b g to a server.;;
0e10: 20 54 68 69 73 20 66 75 6e 63 74 69 6f 6e 2c 20 This function,
0e20: 60 74 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 `tt:client-conne
0e30: 63 74 2d 74 6f 2d 73 65 72 76 65 72 60 2c 20 69 ct-to-server`, i
0e40: 73 20 64 65 73 69 67 6e 65 64 20 74 6f 20 6d 61 s designed to ma
0e50: 6e 61 67 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 nage connections
0e60: 20 62 65 74 77 65 65 6e 20 61 20 63 6c 69 65 6e between a clien
0e70: 74 20 61 6e 64 20 61 20 73 65 72 76 65 72 20 77 t and a server w
0e80: 69 74 68 69 6e 20 61 20 74 65 73 74 69 6e 67 20 ithin a testing
0e90: 66 72 61 6d 65 77 6f 72 6b 2e 0a 3b 3b 20 54 68 framework..;; Th
0ea0: 65 20 66 75 6e 63 74 69 6f 6e 20 74 61 6b 65 73 e function takes
0eb0: 20 66 6f 75 72 20 61 72 67 75 6d 65 6e 74 73 3a four arguments:
0ec0: 0a 3b 3b 20 31 2e 20 60 74 74 64 61 74 60 3a 20 .;; 1. `ttdat`:
0ed0: 61 20 64 61 74 61 20 73 74 72 75 63 74 75 72 65 a data structure
0ee0: 20 74 68 61 74 20 68 6f 6c 64 73 20 69 6e 66 6f that holds info
0ef0: 72 6d 61 74 69 6f 6e 20 61 62 6f 75 74 20 74 68 rmation about th
0f00: 65 20 74 65 73 74 69 6e 67 20 65 6e 76 69 72 6f e testing enviro
0f10: 6e 6d 65 6e 74 20 6f 72 20 63 6f 6e 6e 65 63 74 nment or connect
0f20: 69 6f 6e 73 2e 0a 3b 3b 20 32 2e 20 60 64 62 66 ions..;; 2. `dbf
0f30: 6e 61 6d 65 60 3a 20 54 68 65 20 6e 61 6d 65 20 name`: The name
0f40: 6f 66 20 74 68 65 20 64 61 74 61 62 61 73 65 20 of the database
0f50: 66 69 6c 65 20 74 68 61 74 20 74 68 65 20 63 6c file that the cl
0f60: 69 65 6e 74 20 77 61 6e 74 73 20 74 6f 20 63 6f ient wants to co
0f70: 6e 6e 65 63 74 20 74 6f 2e 0a 3b 3b 20 33 2e 20 nnect to..;; 3.
0f80: 60 72 75 6e 2d 69 64 60 3a 20 41 6e 20 69 64 65 `run-id`: An ide
0f90: 6e 74 69 66 69 65 72 20 66 6f 72 20 74 68 65 20 ntifier for the
0fa0: 63 75 72 72 65 6e 74 20 72 75 6e 20 6f 66 20 74 current run of t
0fb0: 68 65 20 74 65 73 74 20 73 75 69 74 65 2e 0a 3b he test suite..;
0fc0: 3b 20 34 2e 20 60 74 65 73 74 73 75 69 74 65 60 ; 4. `testsuite`
0fd0: 3a 20 54 68 65 20 74 65 73 74 20 73 75 69 74 65 : The test suite
0fe0: 20 74 68 61 74 20 69 73 20 62 65 69 6e 67 20 72 that is being r
0ff0: 75 6e 2e 0a 3b 3b 0a 3b 3b 20 48 65 72 65 27 73 un..;;.;; Here's
1000: 20 61 20 73 74 65 70 2d 62 79 2d 73 74 65 70 20 a step-by-step
1010: 65 78 70 6c 61 6e 61 74 69 6f 6e 20 6f 66 20 77 explanation of w
1020: 68 61 74 20 74 68 65 20 66 75 6e 63 74 69 6f 6e hat the function
1030: 20 64 6f 65 73 3a 0a 3b 3b 0a 3b 3b 20 31 2e 20 does:.;;.;; 1.
1040: 49 74 20 66 69 72 73 74 20 61 73 73 65 72 74 73 It first asserts
1050: 20 74 68 61 74 20 74 68 65 20 60 72 75 6e 2d 69 that the `run-i
1060: 64 60 20 69 73 20 76 61 6c 69 64 20 66 6f 72 20 d` is valid for
1070: 74 68 65 20 67 69 76 65 6e 20 60 64 62 66 6e 61 the given `dbfna
1080: 6d 65 60 20 75 73 69 6e 67 20 74 68 65 20 60 74 me` using the `t
1090: 74 3a 76 61 6c 69 64 2d 72 75 6e 2d 69 64 60 20 t:valid-run-id`
10a0: 66 75 6e 63 74 69 6f 6e 2e 20 49 66 20 74 68 65 function. If the
10b0: 20 60 72 75 6e 2d 69 64 60 20 69 73 20 6e 6f 74 `run-id` is not
10c0: 20 76 61 6c 69 64 2c 20 69 74 20 72 61 69 73 65 valid, it raise
10d0: 73 20 61 20 66 61 74 61 6c 20 65 72 72 6f 72 2e s a fatal error.
10e0: 0a 3b 3b 20 32 2e 20 49 74 20 70 72 69 6e 74 73 .;; 2. It prints
10f0: 20 64 65 62 75 67 20 69 6e 66 6f 72 6d 61 74 69 debug informati
1100: 6f 6e 20 69 6e 64 69 63 61 74 69 6e 67 20 74 68 on indicating th
1110: 61 74 20 74 68 65 20 66 75 6e 63 74 69 6f 6e 20 at the function
1120: 60 74 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 `tt:client-conne
1130: 63 74 2d 74 6f 2d 73 65 72 76 65 72 60 20 68 61 ct-to-server` ha
1140: 73 20 62 65 65 6e 20 63 61 6c 6c 65 64 20 77 69 s been called wi
1150: 74 68 20 74 68 65 20 67 69 76 65 6e 20 60 64 62 th the given `db
1160: 66 6e 61 6d 65 60 2e 0a 3b 3b 20 33 2e 20 49 74 fname`..;; 3. It
1170: 20 61 74 74 65 6d 70 74 73 20 74 6f 20 72 65 74 attempts to ret
1180: 72 69 65 76 65 20 61 6e 20 65 78 69 73 74 69 6e rieve an existin
1190: 67 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 74 6f 20 g connection to
11a0: 74 68 65 20 73 65 72 76 65 72 20 66 72 6f 6d 20 the server from
11b0: 61 20 68 61 73 68 20 74 61 62 6c 65 20 28 60 74 a hash table (`t
11c0: 74 2d 63 6f 6e 6e 73 60 29 20 75 73 69 6e 67 20 t-conns`) using
11d0: 74 68 65 20 60 64 62 66 6e 61 6d 65 60 20 61 73 the `dbfname` as
11e0: 20 74 68 65 20 6b 65 79 2e 20 49 66 20 61 20 63 the key. If a c
11f0: 6f 6e 6e 65 63 74 69 6f 6e 20 61 6c 72 65 61 64 onnection alread
1200: 79 20 65 78 69 73 74 73 2c 20 69 74 20 70 72 69 y exists, it pri
1210: 6e 74 73 20 64 65 62 75 67 20 69 6e 66 6f 72 6d nts debug inform
1220: 61 74 69 6f 6e 20 61 6e 64 20 72 65 74 75 72 6e ation and return
1230: 73 20 74 68 65 20 65 78 69 73 74 69 6e 67 20 63 s the existing c
1240: 6f 6e 6e 65 63 74 69 6f 6e 2e 0a 3b 3b 20 34 2e onnection..;; 4.
1250: 20 49 66 20 6e 6f 20 65 78 69 73 74 69 6e 67 20 If no existing
1260: 63 6f 6e 6e 65 63 74 69 6f 6e 20 69 73 20 66 6f connection is fo
1270: 75 6e 64 2c 20 69 74 20 72 65 74 72 69 65 76 65 und, it retrieve
1280: 73 20 74 68 65 20 63 75 72 72 65 6e 74 20 73 65 s the current se
1290: 72 76 65 72 20 69 6e 66 6f 72 6d 61 74 69 6f 6e rver information
12a0: 20 66 72 6f 6d 20 74 68 65 20 73 65 72 76 69 6e from the servin
12b0: 66 6f 20 66 69 6c 65 2c 20 75 73 69 6e 67 20 74 fo file, using t
12c0: 68 65 20 60 74 74 3a 67 65 74 2d 63 75 72 72 65 he `tt:get-curre
12d0: 6e 74 2d 73 65 72 76 65 72 2d 69 6e 66 6f 60 20 nt-server-info`
12e0: 66 75 6e 63 74 69 6f 6e 2e 0a 3b 3b 20 35 2e 20 function..;; 5.
12f0: 49 74 20 75 73 65 73 20 70 61 74 74 65 72 6e 20 It uses pattern
1300: 6d 61 74 63 68 69 6e 67 20 74 6f 20 64 65 73 74 matching to dest
1310: 72 75 63 74 75 72 65 20 74 68 65 20 73 65 72 76 ructure the serv
1320: 65 72 20 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 69 er information i
1330: 6e 74 6f 20 76 61 72 69 61 62 6c 65 73 20 28 60 nto variables (`
1340: 68 6f 73 74 60 2c 20 60 70 6f 72 74 60 2c 20 60 host`, `port`, `
1350: 73 74 61 72 74 2d 74 69 6d 65 60 2c 20 60 73 65 start-time`, `se
1360: 72 76 65 72 2d 69 64 60 2c 20 60 70 69 64 60 2c rver-id`, `pid`,
1370: 20 60 64 62 66 6e 61 6d 65 32 60 2c 20 60 73 65 `dbfname2`, `se
1380: 72 76 69 6e 66 66 69 6c 65 60 29 2e 20 49 74 20 rvinffile`). It
1390: 74 68 65 6e 20 61 73 73 65 72 74 73 20 74 68 61 then asserts tha
13a0: 74 20 74 68 65 20 60 64 62 66 6e 61 6d 65 60 20 t the `dbfname`
13b0: 66 72 6f 6d 20 74 68 65 20 73 65 72 76 65 72 20 from the server
13c0: 69 6e 66 6f 20 6d 61 74 63 68 65 73 20 74 68 65 info matches the
13d0: 20 6f 6e 65 20 70 72 6f 76 69 64 65 64 20 74 6f one provided to
13e0: 20 74 68 65 20 66 75 6e 63 74 69 6f 6e 2e 0a 3b the function..;
13f0: 3b 20 36 2e 20 49 74 20 63 6f 6e 73 74 72 75 63 ; 6. It construc
1400: 74 73 20 61 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 ts a connection
1410: 6f 62 6a 65 63 74 20 28 60 63 6f 6e 6e 60 29 20 object (`conn`)
1420: 77 69 74 68 20 74 68 65 20 73 65 72 76 65 72 20 with the server
1430: 69 6e 66 6f 72 6d 61 74 69 6f 6e 2e 0a 3b 3b 20 information..;;
1440: 37 2e 20 49 74 20 61 74 74 65 6d 70 74 73 20 74 7. It attempts t
1450: 6f 20 70 69 6e 67 20 74 68 65 20 73 65 72 76 65 o ping the serve
1460: 72 20 75 73 69 6e 67 20 60 74 74 3a 74 69 6d 65 r using `tt:time
1470: 64 2d 70 69 6e 67 60 20 74 6f 20 76 65 72 69 66 d-ping` to verif
1480: 79 20 74 68 61 74 20 74 68 65 20 73 65 72 76 65 y that the serve
1490: 72 20 69 73 20 72 75 6e 6e 69 6e 67 20 61 6e 64 r is running and
14a0: 20 63 61 6e 20 62 65 20 63 6f 6d 6d 75 6e 69 63 can be communic
14b0: 61 74 65 64 20 77 69 74 68 2e 0a 3b 3b 20 38 2e ated with..;; 8.
14c0: 20 44 65 70 65 6e 64 69 6e 67 20 6f 6e 20 74 68 Depending on th
14d0: 65 20 72 65 73 75 6c 74 20 6f 66 20 74 68 65 20 e result of the
14e0: 70 69 6e 67 3a 0a 3b 3b 20 20 20 20 2d 20 49 66 ping:.;; - If
14f0: 20 74 68 65 20 73 65 72 76 65 72 20 69 73 20 72 the server is r
1500: 75 6e 6e 69 6e 67 20 28 60 72 75 6e 6e 69 6e 67 unning (`running
1510: 60 29 2c 20 69 74 20 70 72 69 6e 74 73 20 64 65 `), it prints de
1520: 62 75 67 20 69 6e 66 6f 72 6d 61 74 69 6f 6e 2c bug information,
1530: 20 73 61 76 65 73 20 74 68 65 20 63 6f 6e 6e 65 saves the conne
1540: 63 74 69 6f 6e 20 69 6e 20 74 68 65 20 68 61 73 ction in the has
1550: 68 20 74 61 62 6c 65 2c 20 61 6e 64 20 72 65 74 h table, and ret
1560: 75 72 6e 73 20 74 68 65 20 63 6f 6e 6e 65 63 74 urns the connect
1570: 69 6f 6e 2e 0a 3b 3b 20 20 20 20 2d 20 49 66 20 ion..;; - If
1580: 74 68 65 20 73 65 72 76 65 72 20 69 73 20 73 74 the server is st
1590: 61 72 74 69 6e 67 20 28 60 73 74 61 72 74 69 6e arting (`startin
15a0: 67 60 29 2c 20 69 74 20 73 6c 65 65 70 73 20 66 g`), it sleeps f
15b0: 6f 72 20 32 20 73 65 63 6f 6e 64 73 20 61 6e 64 or 2 seconds and
15c0: 20 74 68 65 6e 20 72 65 63 75 72 73 69 76 65 6c then recursivel
15d0: 79 20 63 61 6c 6c 73 20 69 74 73 65 6c 66 20 74 y calls itself t
15e0: 6f 20 72 65 74 72 79 20 74 68 65 20 63 6f 6e 6e o retry the conn
15f0: 65 63 74 69 6f 6e 2e 0a 3b 3b 20 20 20 20 2d 20 ection..;; -
1600: 49 66 20 74 68 65 20 73 65 72 76 65 72 20 69 73 If the server is
1610: 20 6e 65 69 74 68 65 72 20 72 75 6e 6e 69 6e 67 neither running
1620: 20 6e 6f 72 20 73 74 61 72 74 69 6e 67 2c 20 69 nor starting, i
1630: 74 20 63 68 65 63 6b 73 20 69 66 20 69 74 27 73 t checks if it's
1640: 20 62 65 65 6e 20 6d 6f 72 65 20 74 68 61 6e 20 been more than
1650: 31 30 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 10 seconds since
1660: 20 74 68 65 20 6c 61 73 74 20 73 65 72 76 65 72 the last server
1670: 20 73 74 61 72 74 20 61 74 74 65 6d 70 74 2e 20 start attempt.
1680: 49 66 20 73 6f 2c 20 69 74 20 61 74 74 65 6d 70 If so, it attemp
1690: 74 73 20 74 6f 20 73 74 61 72 74 20 74 68 65 20 ts to start the
16a0: 73 65 72 76 65 72 20 75 73 69 6e 67 20 60 73 65 server using `se
16b0: 72 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 60 rver-start-proc`
16c0: 20 61 6e 64 20 74 68 65 6e 20 73 6c 65 65 70 73 and then sleeps
16d0: 20 66 6f 72 20 31 20 73 65 63 6f 6e 64 20 62 65 for 1 second be
16e0: 66 6f 72 65 20 72 65 74 72 79 69 6e 67 20 74 68 fore retrying th
16f0: 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 2e 0a 3b 3b e connection..;;
1700: 20 39 2e 20 49 66 20 6e 6f 20 73 65 72 76 65 72 9. If no server
1710: 20 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 69 73 20 information is
1720: 66 6f 75 6e 64 20 28 60 65 6c 73 65 60 20 63 61 found (`else` ca
1730: 73 65 29 2c 20 69 74 20 63 68 65 63 6b 73 20 69 se), it checks i
1740: 66 20 69 74 27 73 20 62 65 65 6e 20 6d 6f 72 65 f it's been more
1750: 20 74 68 61 6e 20 33 20 73 65 63 6f 6e 64 73 20 than 3 seconds
1760: 73 69 6e 63 65 20 74 68 65 20 6c 61 73 74 20 73 since the last s
1770: 65 72 76 65 72 20 73 74 61 72 74 20 61 74 74 65 erver start atte
1780: 6d 70 74 2e 20 49 66 20 73 6f 2c 20 69 74 20 73 mpt. If so, it s
1790: 74 61 72 74 73 20 61 20 6e 65 77 20 73 65 72 76 tarts a new serv
17a0: 65 72 20 75 73 69 6e 67 20 60 73 65 72 76 65 72 er using `server
17b0: 2d 73 74 61 72 74 2d 70 72 6f 63 60 2c 20 75 70 -start-proc`, up
17c0: 64 61 74 65 73 20 74 68 65 20 6c 61 73 74 20 73 dates the last s
17d0: 65 72 76 65 72 20 73 74 61 72 74 20 74 69 6d 65 erver start time
17e0: 2c 20 61 6e 64 20 73 6c 65 65 70 73 20 66 6f 72 , and sleeps for
17f0: 20 34 20 73 65 63 6f 6e 64 73 2e 0a 3b 3b 20 31 4 seconds..;; 1
1800: 30 2e 20 49 74 20 74 68 65 6e 20 73 6c 65 65 70 0. It then sleep
1810: 73 20 66 6f 72 20 31 20 73 65 63 6f 6e 64 20 61 s for 1 second a
1820: 6e 64 20 70 72 69 6e 74 73 20 64 65 62 75 67 20 nd prints debug
1830: 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 62 65 66 6f information befo
1840: 72 65 20 72 65 63 75 72 73 69 76 65 6c 79 20 63 re recursively c
1850: 61 6c 6c 69 6e 67 20 69 74 73 65 6c 66 20 74 6f alling itself to
1860: 20 72 65 74 72 79 20 74 68 65 20 63 6f 6e 6e 65 retry the conne
1870: 63 74 69 6f 6e 2e 0a 3b 3b 0a 3b 3b 20 54 68 65 ction..;;.;; The
1880: 20 66 75 6e 63 74 69 6f 6e 20 75 73 65 73 20 72 function uses r
1890: 65 63 75 72 73 69 6f 6e 20 74 6f 20 6b 65 65 70 ecursion to keep
18a0: 20 74 72 79 69 6e 67 20 74 6f 20 63 6f 6e 6e 65 trying to conne
18b0: 63 74 20 74 6f 20 74 68 65 20 73 65 72 76 65 72 ct to the server
18c0: 2c 20 77 69 74 68 20 76 61 72 69 6f 75 73 20 73 , with various s
18d0: 6c 65 65 70 20 69 6e 74 65 72 76 61 6c 73 20 74 leep intervals t
18e0: 6f 20 70 72 65 76 65 6e 74 20 6f 76 65 72 77 68 o prevent overwh
18f0: 65 6c 6d 69 6e 67 20 74 68 65 20 73 79 73 74 65 elming the syste
1900: 6d 20 77 69 74 68 20 63 6f 6e 6e 65 63 74 69 6f m with connectio
1910: 6e 20 61 74 74 65 6d 70 74 73 20 6f 72 20 73 65 n attempts or se
1920: 72 76 65 72 20 73 74 61 72 74 73 2e 0a 3b 3b 20 rver starts..;;
1930: 49 74 20 61 6c 73 6f 20 75 73 65 73 20 61 20 68 It also uses a h
1940: 61 73 68 20 74 61 62 6c 65 20 74 6f 20 63 61 63 ash table to cac
1950: 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 61 he connections a
1960: 6e 64 20 61 76 6f 69 64 20 72 65 63 6f 6e 6e 65 nd avoid reconne
1970: 63 74 69 6e 67 20 74 6f 20 61 20 73 65 72 76 65 cting to a serve
1980: 72 20 69 66 20 61 20 63 6f 6e 6e 65 63 74 69 6f r if a connectio
1990: 6e 20 61 6c 72 65 61 64 79 20 65 78 69 73 74 73 n already exists
19a0: 2e 0a 3b 3b 20 54 68 65 20 66 75 6e 63 74 69 6f ..;; The functio
19b0: 6e 20 69 73 20 64 65 73 69 67 6e 65 64 20 74 6f n is designed to
19c0: 20 68 61 6e 64 6c 65 20 64 69 66 66 65 72 65 6e handle differen
19d0: 74 20 73 65 72 76 65 72 20 73 74 61 74 65 73 20 t server states
19e0: 61 6e 64 20 65 6e 73 75 72 65 20 74 68 61 74 20 and ensure that
19f0: 61 20 73 65 72 76 65 72 20 69 73 20 72 75 6e 6e a server is runn
1a00: 69 6e 67 20 61 6e 64 20 61 76 61 69 6c 61 62 6c ing and availabl
1a10: 65 20 62 65 66 6f 72 65 20 72 65 74 75 72 6e 69 e before returni
1a20: 6e 67 20 61 20 76 61 6c 69 64 20 63 6f 6e 6e 65 ng a valid conne
1a30: 63 74 69 6f 6e 20 74 6f 20 74 68 65 20 63 61 6c ction to the cal
1a40: 6c 65 72 2e 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 ler..;; .(define
1a50: 20 28 74 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e (tt:client-conn
1a60: 65 63 74 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 ect-to-server tt
1a70: 64 61 74 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d dat dbfname run-
1a80: 69 64 20 74 65 73 74 73 75 69 74 65 20 73 65 72 id testsuite ser
1a90: 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 29 0a ver-start-proc).
1aa0: 20 20 28 61 73 73 65 72 74 20 28 74 74 3a 76 61 (assert (tt:va
1ab0: 6c 69 64 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 lid-run-id run-i
1ac0: 64 20 64 62 66 6e 61 6d 65 29 20 22 46 41 54 41 d dbfname) "FATA
1ad0: 4c 3a 20 69 6e 76 61 6c 69 64 20 72 75 6e 2d 69 L: invalid run-i
1ae0: 64 20 22 72 75 6e 2d 69 64 29 0a 20 20 28 64 65 d "run-id). (de
1af0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
1b00: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1b10: 72 74 2a 20 22 74 74 3a 63 6c 69 65 6e 74 2d 63 rt* "tt:client-c
1b20: 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 65 72 onnect-to-server
1b30: 20 22 20 64 62 66 6e 61 6d 65 29 0a 20 20 28 6c " dbfname). (l
1b40: 65 74 2a 20 28 28 63 6f 6e 6e 20 20 20 20 20 20 et* ((conn
1b50: 20 20 20 20 20 20 20 20 28 74 74 3a 67 65 74 2d (tt:get-
1b60: 63 6f 6e 6e 20 74 74 64 61 74 20 64 62 66 6e 61 conn ttdat dbfna
1b70: 6d 65 29 29 0a 09 20 28 73 65 72 76 65 72 2d 73 me)).. (server-s
1b80: 74 61 72 74 2d 70 72 6f 63 20 28 6f 72 20 73 65 tart-proc (or se
1b90: 72 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 0a rver-start-proc.
1ba0: 09 09 09 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 ....(lambda ()..
1bb0: 09 09 09 20 20 28 61 73 73 65 72 74 20 28 65 71 ... (assert (eq
1bc0: 75 61 6c 3f 20 64 62 66 6e 61 6d 65 20 22 6d 61 ual? dbfname "ma
1bd0: 69 6e 2e 64 62 22 29 20 3b 3b 20 6f 6e 6c 79 20 in.db") ;; only
1be0: 6d 61 69 6e 2e 64 62 20 69 73 20 73 74 61 72 74 main.db is start
1bf0: 65 64 20 68 65 72 65 0a 09 09 09 09 09 20 20 22 ed here...... "
1c00: 46 41 54 41 4c 3a 20 63 61 6c 6c 65 64 20 73 65 FATAL: called se
1c10: 72 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 20 rver-start-proc
1c20: 66 6f 72 20 64 62 20 6f 74 68 65 72 20 74 68 61 for db other tha
1c30: 6e 20 6d 61 69 6e 2e 64 62 22 29 0a 09 09 09 09 n main.db").....
1c40: 20 20 28 74 74 3a 73 65 72 76 65 72 2d 70 72 6f (tt:server-pro
1c50: 63 65 73 73 2d 72 75 6e 0a 09 09 09 09 20 20 20 cess-run.....
1c60: 28 74 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 (tt-areapath ttd
1c70: 61 74 29 0a 09 09 09 09 20 20 20 74 65 73 74 73 at)..... tests
1c80: 75 69 74 65 20 3b 3b 20 28 64 62 66 69 6c 65 3a uite ;; (dbfile:
1c90: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a testsuite-name).
1ca0: 09 09 09 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 .... (common:f
1cb0: 69 6e 64 2d 6c 6f 63 61 6c 2d 6d 65 67 61 74 65 ind-local-megate
1cc0: 73 74 29 0a 09 09 09 09 20 20 20 72 75 6e 2d 69 st)..... run-i
1cd0: 64 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 63 d))))). (if c
1ce0: 6f 6e 6e 0a 09 28 62 65 67 69 6e 20 0a 20 20 20 onn..(begin .
1cf0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
1d00: 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 int-info 2 *defa
1d10: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 ult-log-port* "a
1d20: 6c 72 65 61 64 79 20 63 6f 6e 6e 65 63 74 65 64 lready connected
1d30: 20 74 6f 20 61 20 73 65 72 76 65 72 20 66 6f 72 to a server for
1d40: 20 22 20 64 62 66 6e 61 6d 65 29 0a 20 20 20 20 " dbfname).
1d50: 20 20 20 20 20 20 20 63 6f 6e 6e 29 20 3b 3b 20 conn) ;;
1d60: 77 65 20 61 72 65 20 61 6c 72 65 61 64 79 20 63 we are already c
1d70: 6f 6e 6e 65 63 74 65 64 20 74 6f 20 74 68 65 20 onnected to the
1d80: 73 65 72 76 65 72 0a 0a 09 3b 3b 20 6e 6f 20 63 server...;; no c
1d90: 6f 6e 6e 0a 0a 09 3b 3b 20 66 69 6e 64 20 73 65 onn...;; find se
1da0: 72 76 65 72 20 77 69 74 68 20 6c 6f 77 65 73 74 rver with lowest
1db0: 20 6e 75 6d 62 65 72 20 6f 66 20 74 68 72 65 61 number of threa
1dc0: 64 73 20 72 75 6e 6e 69 6e 67 20 28 69 2e 65 2e ds running (i.e.
1dd0: 20 6c 6f 77 65 73 74 20 6c 6f 61 64 29 0a 09 3b lowest load)..;
1de0: 3b 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ;. (let*
1df0: 28 28 73 64 61 74 73 20 28 74 74 3a 67 65 74 2d ((sdats (tt:get-
1e00: 73 65 72 76 65 72 2d 69 6e 66 6f 2d 73 6f 72 74 server-info-sort
1e10: 65 64 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 ed ttdat dbfname
1e20: 29 29 0a 09 20 20 20 20 20 20 20 28 73 64 61 74 )).. (sdat
1e30: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 73 64 61 (if (null? sda
1e40: 74 73 29 0a 09 09 09 20 20 23 66 0a 09 09 09 20 ts).... #f....
1e50: 20 3b 3b 20 63 68 6f 6f 73 65 20 73 65 72 76 65 ;; choose serve
1e60: 72 20 77 69 74 68 20 6c 6f 77 65 73 74 20 74 68 r with lowest th
1e70: 72 65 61 64 73 20 63 6f 75 6e 74 0a 09 09 09 20 reads count....
1e80: 20 28 63 61 72 20 28 73 6f 72 74 20 73 64 61 74 (car (sort sdat
1e90: 73 0a 09 09 09 09 20 20 20 20 20 28 6c 61 6d 62 s..... (lamb
1ea0: 64 61 20 28 61 20 62 29 0a 09 09 09 09 20 20 20 da (a b).....
1eb0: 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 (let* ((load
1ec0: 2d 61 20 28 74 74 3a 67 65 74 2d 73 65 72 76 65 -a (tt:get-serve
1ed0: 72 2d 74 68 72 65 61 64 73 20 61 29 29 0a 09 09 r-threads a))...
1ee0: 09 09 09 20 20 20 20 20 20 28 6c 6f 61 64 2d 62 ... (load-b
1ef0: 20 28 74 74 3a 67 65 74 2d 73 65 72 76 65 72 2d (tt:get-server-
1f00: 74 68 72 65 61 64 73 20 62 29 29 29 0a 09 09 09 threads b)))....
1f10: 09 09 20 28 3c 20 6c 6f 61 64 2d 61 20 6c 6f 61 .. (< load-a loa
1f20: 64 2d 62 29 29 29 29 29 29 29 29 0a 09 09 09 09 d-b)))))))).....
1f30: 20 20 20 20 20 0a 09 20 20 3b 3b 20 28 6c 65 74 .. ;; (let
1f40: 20 28 28 69 6e 64 78 20 28 6d 61 78 20 28 72 61 ((indx (max (ra
1f50: 6e 64 6f 6d 20 28 2d 20 28 6c 65 6e 67 74 68 20 ndom (- (length
1f60: 73 64 61 74 73 29 20 31 29 29 20 30 29 29 29 0a sdats) 1)) 0))).
1f70: 09 20 20 3b 3b 20 20 20 20 28 6c 69 73 74 2d 72 . ;; (list-r
1f80: 65 66 20 73 64 61 74 73 20 69 6e 64 78 29 29 29 ef sdats indx)))
1f90: 29 29 0a 09 20 20 3b 3b 20 28 64 65 62 75 67 3a )).. ;; (debug:
1fa0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 print-info 1 *de
1fb0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1fc0: 22 66 6f 75 6e 64 20 73 64 61 74 20 22 20 73 64 "found sdat " sd
1fd0: 61 74 22 20 66 72 6f 6d 20 73 64 61 74 73 3a 20 at" from sdats:
1fe0: 22 73 64 61 74 73 29 0a 20 20 20 20 20 20 20 20 "sdats).
1ff0: 20 20 28 6d 61 74 63 68 20 73 64 61 74 0a 09 20 (match sdat..
2000: 20 20 20 28 28 68 6f 73 74 20 70 6f 72 74 20 73 ((host port s
2010: 74 61 72 74 2d 74 69 6d 65 20 73 65 72 76 65 72 tart-time server
2020: 2d 69 64 20 70 69 64 20 64 62 66 6e 61 6d 65 32 -id pid dbfname2
2030: 20 73 65 72 76 69 6e 66 66 69 6c 65 29 0a 09 20 servinffile)..
2040: 20 20 20 20 28 61 73 73 65 72 74 20 28 65 71 75 (assert (equ
2050: 61 6c 3f 20 64 62 66 6e 61 6d 65 20 64 62 66 6e al? dbfname dbfn
2060: 61 6d 65 32 29 20 22 46 41 54 41 4c 3a 20 72 65 ame2) "FATAL: re
2070: 61 64 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 ad server info f
2080: 72 6f 6d 20 77 72 6f 6e 67 20 66 69 6c 65 2e 22 rom wrong file."
2090: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
20a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
20b0: 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 2 *default-log-
20c0: 70 6f 72 74 2a 20 22 6e 6f 20 63 6f 6e 6e 20 2d port* "no conn -
20d0: 20 69 6e 20 6d 61 74 63 68 20 73 65 72 76 69 6e in match servin
20e0: 66 66 69 6c 65 3a 22 20 73 65 72 76 69 6e 66 66 ffile:" servinff
20f0: 69 6c 65 29 0a 09 20 20 20 20 20 28 6c 65 74 2a ile).. (let*
2100: 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 28 63 6f ((host-port (co
2110: 6e 63 20 68 6f 73 74 22 3a 22 70 6f 72 74 29 29 nc host":"port))
2120: 0a 09 09 20 20 20 20 28 63 6f 6e 6e 20 28 6d 61 ... (conn (ma
2130: 6b 65 2d 74 74 2d 63 6f 6e 6e 0a 09 09 09 20 20 ke-tt-conn....
2140: 20 68 6f 73 74 3a 20 68 6f 73 74 0a 09 09 09 20 host: host....
2150: 20 20 70 6f 72 74 3a 20 70 6f 72 74 0a 09 09 09 port: port....
2160: 20 20 20 68 6f 73 74 2d 70 6f 72 74 3a 20 68 6f host-port: ho
2170: 73 74 2d 70 6f 72 74 0a 09 09 09 20 20 20 64 62 st-port.... db
2180: 66 6e 61 6d 65 3a 20 64 62 66 6e 61 6d 65 0a 09 fname: dbfname..
2190: 09 09 20 20 20 73 65 72 76 69 6e 66 2d 66 69 6c .. servinf-fil
21a0: 65 3a 20 73 65 72 76 69 6e 66 66 69 6c 65 0a 09 e: servinffile..
21b0: 09 09 20 20 20 73 65 72 76 65 72 2d 69 64 3a 20 .. server-id:
21c0: 73 65 72 76 65 72 2d 69 64 0a 09 09 09 20 20 20 server-id....
21d0: 73 65 72 76 65 72 2d 73 74 61 72 74 3a 20 73 74 server-start: st
21e0: 61 72 74 2d 74 69 6d 65 0a 09 09 09 20 20 20 70 art-time.... p
21f0: 69 64 3a 20 70 69 64 29 29 29 0a 09 20 20 20 20 id: pid)))..
2200: 20 20 20 3b 3b 20 76 65 72 69 66 79 20 77 65 20 ;; verify we
2210: 63 61 6e 20 74 61 6c 6b 20 74 6f 20 74 68 69 73 can talk to this
2220: 20 73 65 72 76 65 72 0a 09 20 20 20 20 20 20 20 server..
2230: 28 6c 65 74 2a 20 28 28 72 65 73 75 6c 74 20 20 (let* ((result
2240: 20 28 74 74 3a 74 69 6d 65 64 2d 70 69 6e 67 20 (tt:timed-ping
2250: 68 6f 73 74 20 70 6f 72 74 20 73 65 72 76 65 72 host port server
2260: 2d 69 64 29 29 0a 09 09 20 20 20 20 20 20 28 70 -id))... (p
2270: 69 6e 67 2d 72 65 73 20 28 63 61 72 20 72 65 73 ing-res (car res
2280: 75 6c 74 29 29 0a 09 09 20 20 20 20 20 20 28 70 ult))... (p
2290: 69 6e 67 20 20 20 20 20 28 63 64 72 20 72 65 73 ing (cdr res
22a0: 75 6c 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 ult))).
22b0: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
22c0: 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 rint-info 2 *def
22d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
22e0: 68 6f 73 74 20 22 20 68 6f 73 74 20 22 20 70 6f host " host " po
22f0: 72 74 20 22 20 70 6f 72 74 20 22 20 70 69 6e 67 rt " port " ping
2300: 20 74 69 6d 65 3a 20 22 20 70 69 6e 67 20 22 20 time: " ping "
2310: 72 65 73 75 6c 74 20 22 20 70 69 6e 67 2d 72 65 result " ping-re
2320: 73 29 0a 09 09 20 28 63 61 73 65 20 70 69 6e 67 s)... (case ping
2330: 2d 72 65 73 0a 09 09 20 20 20 28 28 72 75 6e 6e -res... ((runn
2340: 69 6e 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 ing).
2350: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
2360: 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 print-info 2 *de
2370: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2380: 22 53 65 74 74 69 6e 67 20 63 6f 6e 6e 20 3d 20 "Setting conn =
2390: 22 20 63 6f 6e 6e 20 22 20 69 6e 20 68 61 73 68 " conn " in hash
23a0: 20 74 61 62 6c 65 22 29 0a 09 09 20 20 20 20 28 table")... (
23b0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
23c0: 28 74 74 2d 63 6f 6e 6e 73 20 74 74 64 61 74 29 (tt-conns ttdat)
23d0: 20 64 62 66 6e 61 6d 65 20 63 6f 6e 6e 29 20 3b dbfname conn) ;
23e0: 3b 3b 20 69 73 20 74 68 69 73 20 6f 6b 20 74 6f ;; is this ok to
23f0: 20 73 61 76 65 20 62 65 66 6f 72 65 20 76 61 6c save before val
2400: 69 64 61 74 69 6e 67 20 74 68 61 74 20 74 68 65 idating that the
2410: 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 69 73 20 67 connection is g
2420: 6f 6f 64 3f 0a 09 09 20 20 20 20 63 6f 6e 6e 29 ood?... conn)
2430: 0a 09 09 20 20 20 28 28 73 74 61 72 74 69 6e 67 ... ((starting
2440: 29 0a 09 09 20 20 20 20 28 74 68 72 65 61 64 2d )... (thread-
2450: 73 6c 65 65 70 21 20 30 2e 35 29 0a 20 20 20 20 sleep! 0.5).
2460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2470: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2480: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
2490: 2d 70 6f 72 74 2a 20 22 73 65 72 76 65 72 20 66 -port* "server f
24a0: 6f 72 20 22 20 64 62 66 6e 61 6d 65 20 22 20 69 or " dbfname " i
24b0: 73 20 69 6e 20 73 74 61 72 74 69 6e 67 20 73 74 s in starting st
24c0: 61 74 65 2c 20 72 65 74 72 79 69 6e 67 20 63 6f ate, retrying co
24d0: 6e 6e 65 63 74 22 29 0a 09 09 20 20 20 20 28 74 nnect")... (t
24e0: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
24f0: 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 64 61 74 -to-server ttdat
2500: 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 dbfname run-id
2510: 74 65 73 74 73 75 69 74 65 20 73 65 72 76 65 72 testsuite server
2520: 2d 73 74 61 72 74 2d 70 72 6f 63 29 29 0a 09 09 -start-proc))...
2530: 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 28 (else... (
2540: 6c 65 74 2a 20 28 28 63 75 72 72 2d 73 65 63 73 let* ((curr-secs
2550: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
2560: 73 29 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 s)))... ;;
2570: 72 6d 20 74 68 65 20 28 6c 61 73 74 20 73 65 72 rm the (last ser
2580: 76 65 72 29 20 77 6f 75 6c 64 20 67 6f 20 68 65 ver) would go he
2590: 72 65 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 re... (if (
25a0: 3e 20 28 2d 20 63 75 72 72 2d 73 65 63 73 20 28 > (- curr-secs (
25b0: 74 74 2d 6c 61 73 74 2d 73 65 72 76 2d 73 74 61 tt-last-serv-sta
25c0: 72 74 20 74 74 64 61 74 29 29 20 31 30 29 0a 09 rt ttdat)) 10)..
25d0: 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 .. (begin....
25e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
25f0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
2600: 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 72 65 61 63 og-port* "Unreac
2610: 68 61 62 6c 65 20 73 65 72 76 65 72 20 61 74 20 hable server at
2620: 22 0a 09 09 09 09 09 20 20 20 20 20 20 68 6f 73 "...... hos
2630: 74 22 3a 22 70 6f 72 74 22 20 77 69 74 68 20 73 t":"port" with s
2640: 65 72 76 69 6e 66 6f 20 66 69 6c 65 20 22 73 65 ervinfo file "se
2650: 72 76 69 6e 66 66 69 6c 65 22 2c 20 72 65 6d 6f rvinffile", remo
2660: 76 69 6e 67 20 69 74 22 29 0a 09 09 09 20 20 20 ving it")....
2670: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
2680: 73 3f 20 73 65 72 76 69 6e 66 66 69 6c 65 29 0a s? servinffile).
2690: 09 09 09 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 ....(handle-exce
26a0: 70 74 69 6f 6e 73 0a 09 09 09 09 20 65 78 6e 0a ptions..... exn.
26b0: 09 09 09 09 20 23 66 0a 09 09 09 09 20 28 64 65 .... #f..... (de
26c0: 6c 65 74 65 2d 66 69 6c 65 20 73 65 72 76 69 6e lete-file servin
26d0: 66 66 69 6c 65 29 29 29 0a 09 09 09 20 20 20 20 ffile)))....
26e0: 28 74 74 2d 6c 61 73 74 2d 73 65 72 76 2d 73 74 (tt-last-serv-st
26f0: 61 72 74 2d 73 65 74 21 20 74 74 64 61 74 20 63 art-set! ttdat c
2700: 75 72 72 2d 73 65 63 73 29 0a 20 20 20 20 20 20 urr-secs).
2710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2720: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
2730: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
2740: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 lt-log-port* "St
2750: 61 72 74 69 6e 67 20 61 20 6e 65 77 20 73 65 72 arting a new ser
2760: 76 65 72 20 6f 6e 20 22 20 28 67 65 74 2d 68 6f ver on " (get-ho
2770: 73 74 2d 6e 61 6d 65 29 29 0a 09 09 09 20 20 20 st-name))....
2780: 20 28 73 65 72 76 65 72 2d 73 74 61 72 74 2d 70 (server-start-p
2790: 72 6f 63 29 29 29 20 3b 3b 20 73 74 61 72 74 20 roc))) ;; start
27a0: 73 65 72 76 65 72 20 69 66 20 31 30 20 73 65 63 server if 10 sec
27b0: 20 73 69 6e 63 65 20 6c 61 73 74 20 61 74 74 65 since last atte
27c0: 6d 70 74 0a 09 09 20 20 20 20 20 20 28 74 68 72 mpt... (thr
27d0: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 20 20 ead-sleep! 1).
27e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27f0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2800: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
2810: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 74 72 -log-port* "Retr
2820: 79 69 6e 67 20 63 6f 6e 6e 65 63 74 22 29 0a 09 ying connect")..
2830: 09 20 20 20 20 20 20 28 74 74 3a 63 6c 69 65 6e . (tt:clien
2840: 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 t-connect-to-ser
2850: 76 65 72 20 74 74 64 61 74 20 64 62 66 6e 61 6d ver ttdat dbfnam
2860: 65 20 72 75 6e 2d 69 64 20 74 65 73 74 73 75 69 e run-id testsui
2870: 74 65 20 73 65 72 76 65 72 2d 73 74 61 72 74 2d te server-start-
2880: 70 72 6f 63 29 29 29 29 29 29 29 0a 0a 09 20 20 proc)))))))...
2890: 20 20 28 65 6c 73 65 20 3b 3b 20 6e 6f 20 67 6f (else ;; no go
28a0: 6f 64 20 73 65 72 76 65 72 20 66 6f 75 6e 64 2c od server found,
28b0: 20 69 66 20 68 61 76 65 6e 27 74 20 73 74 61 72 if haven't star
28c0: 74 65 64 20 73 65 72 76 65 72 20 69 6e 20 3e 20 ted server in >
28d0: 35 20 73 65 63 73 2c 20 73 74 61 72 74 20 61 6e 5 secs, start an
28e0: 6f 74 68 65 72 0a 09 20 20 20 20 20 28 69 66 20 other.. (if
28f0: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
2900: 65 63 6f 6e 64 73 29 20 28 74 74 2d 6c 61 73 74 econds) (tt-last
2910: 2d 73 65 72 76 2d 73 74 61 72 74 20 74 74 64 61 -serv-start ttda
2920: 74 29 29 20 33 29 20 3b 3b 20 42 55 47 20 2d 20 t)) 3) ;; BUG -
2930: 67 72 6f 77 20 74 68 69 73 20 6e 75 6d 62 65 72 grow this number
2940: 20 72 65 61 6c 6c 79 20 64 6f 20 6e 6f 74 20 77 really do not w
2950: 61 6e 74 20 74 6f 20 73 77 61 6d 70 20 74 68 65 ant to swamp the
2960: 20 6d 61 63 68 69 6e 65 20 77 69 74 68 20 73 65 machine with se
2970: 72 76 65 72 73 0a 09 09 20 28 62 65 67 69 6e 0a rvers... (begin.
2980: 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
2990: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
29a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 t-log-port* "Sta
29b0: 72 74 69 6e 67 20 73 65 72 76 65 72 20 66 6f 72 rting server for
29c0: 20 22 64 62 66 6e 61 6d 65 20 22 20 6f 6e 20 22 "dbfname " on "
29d0: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
29e0: 29 0a 09 09 20 20 20 28 73 65 72 76 65 72 2d 73 )... (server-s
29f0: 74 61 72 74 2d 70 72 6f 63 29 0a 09 09 20 20 20 tart-proc)...
2a00: 28 74 74 2d 6c 61 73 74 2d 73 65 72 76 2d 73 74 (tt-last-serv-st
2a10: 61 72 74 2d 73 65 74 21 20 74 74 64 61 74 20 28 art-set! ttdat (
2a20: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
2a30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2a40: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
2a50: 65 70 21 20 36 29 0a 20 20 20 20 20 20 20 20 20 ep! 6).
2a60: 20 20 20 20 20 20 20 20 20 20 29 29 0a 09 20 20 ))..
2a70: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
2a80: 21 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 ! 1).
2a90: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
2aa0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
2ab0: 6f 67 2d 70 6f 72 74 2a 20 22 43 6f 6e 6e 65 63 og-port* "Connec
2ac0: 74 20 74 6f 20 73 65 72 76 65 72 20 66 72 6f 6d t to server from
2ad0: 20 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d " (get-host-nam
2ae0: 65 29 20 22 20 66 6f 72 20 22 20 64 62 66 6e 61 e) " for " dbfna
2af0: 6d 65 29 0a 09 20 20 20 20 20 28 74 74 3a 63 6c me).. (tt:cl
2b00: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d ient-connect-to-
2b10: 73 65 72 76 65 72 20 74 74 64 61 74 20 64 62 66 server ttdat dbf
2b20: 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 name run-id test
2b30: 73 75 69 74 65 20 73 65 72 76 65 72 2d 73 74 61 suite server-sta
2b40: 72 74 2d 70 72 6f 63 29 29 29 29 29 29 29 0a 0a rt-proc)))))))..
2b50: 3b 3b 20 72 65 74 75 72 6e 73 20 28 20 72 65 73 ;; returns ( res
2b60: 75 6c 74 20 2e 20 70 69 6e 67 5f 74 69 6d 65 20 ult . ping_time
2b70: 29 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 74 69 ).(define (tt:ti
2b80: 6d 65 64 2d 70 69 6e 67 20 68 6f 73 74 20 70 6f med-ping host po
2b90: 72 74 20 73 65 72 76 65 72 2d 69 64 29 0a 20 20 rt server-id).
2ba0: 28 6c 65 74 2a 20 28 28 73 74 61 72 74 2d 74 69 (let* ((start-ti
2bb0: 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c me (current-mill
2bc0: 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 72 65 iseconds)).. (re
2bd0: 73 75 6c 74 20 20 20 20 20 28 74 74 3a 70 69 6e sult (tt:pin
2be0: 67 20 68 6f 73 74 20 70 6f 72 74 20 73 65 72 76 g host port serv
2bf0: 65 72 2d 69 64 29 29 29 0a 20 20 20 20 28 63 6f er-id))). (co
2c00: 6e 73 20 72 65 73 75 6c 74 20 28 2d 20 28 63 75 ns result (- (cu
2c10: 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
2c20: 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 ds) start-time))
2c30: 29 29 0a 0a 3b 3b 20 68 6f 73 74 3a 70 6f 72 74 ))..;; host:port
2c40: 20 3d 3e 20 28 20 6d 65 74 61 20 2e 20 77 68 65 => ( meta . whe
2c50: 6e 2d 75 70 64 61 74 65 64 29 0a 28 64 65 66 69 n-updated).(defi
2c60: 6e 65 20 2a 73 65 72 76 65 72 2d 6c 6f 61 64 2a ne *server-load*
2c70: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
2c80: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 e))..(define (tt
2c90: 3a 73 61 76 65 2d 73 65 72 76 65 72 2d 6d 65 74 :save-server-met
2ca0: 61 20 68 6f 73 74 20 70 6f 72 74 20 6d 65 74 61 a host port meta
2cb0: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
2cc0: 73 65 74 21 20 2a 73 65 72 76 65 72 2d 6c 6f 61 set! *server-loa
2cd0: 64 2a 20 28 63 6f 6e 63 20 68 6f 73 74 22 3a 22 d* (conc host":"
2ce0: 70 6f 72 74 29 20 28 63 6f 6e 73 20 6d 65 74 61 port) (cons meta
2cf0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
2d00: 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s))))..(define (
2d10: 74 74 3a 67 65 74 2d 73 65 72 76 65 72 2d 74 68 tt:get-server-th
2d20: 72 65 61 64 73 20 64 61 74 29 0a 20 20 28 6c 65 reads dat). (le
2d30: 74 2a 20 28 28 68 6f 73 74 20 28 63 61 72 20 20 t* ((host (car
2d40: 64 61 74 29 29 0a 09 20 28 70 6f 72 74 20 28 63 dat)).. (port (c
2d50: 61 64 72 20 64 61 74 29 29 0a 09 20 28 64 61 74 adr dat)).. (dat
2d60: 20 20 28 74 74 3a 67 65 74 2d 73 65 72 76 65 72 (tt:get-server
2d70: 2d 6d 65 74 61 20 68 6f 73 74 20 70 6f 72 74 20 -meta host port
2d80: 23 74 29 29 29 0a 20 20 20 20 3b 3b 20 28 64 65 #t))). ;; (de
2d90: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
2da0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2db0: 68 6f 73 74 3a 20 22 68 6f 73 74 22 20 70 6f 72 host: "host" por
2dc0: 74 3a 20 22 70 6f 72 74 22 20 64 61 74 3a 20 22 t: "port" dat: "
2dd0: 64 61 74 29 0a 20 20 20 20 28 69 66 20 28 6c 69 dat). (if (li
2de0: 73 74 3f 20 64 61 74 29 0a 09 28 6f 72 20 28 61 st? dat)..(or (a
2df0: 6c 69 73 74 2d 72 65 66 20 27 73 6c 6f 61 64 20 list-ref 'sload
2e00: 64 61 74 29 20 39 39 39 39 38 29 0a 09 39 39 39 dat) 99998)..999
2e10: 39 39 29 29 29 20 3b 3b 20 61 62 73 75 72 64 20 99))) ;; absurd
2e20: 6e 75 6d 62 65 72 20 6d 65 61 6e 73 20 64 6f 6e number means don
2e30: 27 74 20 75 73 65 20 74 68 69 73 20 6f 6e 65 0a 't use this one.
2e40: 0a 3b 3b 20 6c 61 7a 79 20 67 65 74 2c 20 64 6f .;; lazy get, do
2e50: 65 73 20 6e 6f 74 20 61 75 74 6f 2d 72 65 66 72 es not auto-refr
2e60: 65 73 68 20 6d 65 74 61 2c 20 74 68 69 73 20 6d esh meta, this m
2e70: 69 67 68 74 20 62 65 20 61 20 70 72 6f 62 6c 65 ight be a proble
2e80: 6d 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 74 m.;;.(define (tt
2e90: 3a 67 65 74 2d 73 65 72 76 65 72 2d 6d 65 74 61 :get-server-meta
2ea0: 20 68 6f 73 74 20 70 6f 72 74 20 23 21 6f 70 74 host port #!opt
2eb0: 69 6f 6e 61 6c 20 28 64 6f 2d 70 69 6e 67 20 23 ional (do-ping #
2ec0: 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 67 65 f)). (let* ((ge
2ed0: 74 2d 6d 65 74 61 20 28 6c 61 6d 62 64 61 20 28 t-meta (lambda (
2ee0: 29 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 )... (let* (
2ef0: 28 64 61 74 20 20 28 68 61 73 68 2d 74 61 62 6c (dat (hash-tabl
2f00: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 e-ref/default *s
2f10: 65 72 76 65 72 2d 6c 6f 61 64 2a 20 28 63 6f 6e erver-load* (con
2f20: 63 20 68 6f 73 74 22 3a 22 70 6f 72 74 29 20 23 c host":"port) #
2f30: 66 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 f)))... (i
2f40: 66 20 64 61 74 20 28 63 61 72 20 64 61 74 29 20 f dat (car dat)
2f50: 23 66 29 29 29 29 0a 09 20 28 6d 65 74 61 20 20 #f)))).. (meta
2f60: 20 20 20 28 67 65 74 2d 6d 65 74 61 29 29 29 0a (get-meta))).
2f70: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f (if (and (no
2f80: 74 20 6d 65 74 61 29 0a 09 20 20 20 20 20 64 6f t meta).. do
2f90: 2d 70 69 6e 67 29 0a 09 28 62 65 67 69 6e 0a 09 -ping)..(begin..
2fa0: 20 20 28 74 74 3a 74 69 6d 65 64 2d 70 69 6e 67 (tt:timed-ping
2fb0: 20 68 6f 73 74 20 70 6f 72 74 20 23 66 29 0a 09 host port #f)..
2fc0: 20 20 28 67 65 74 2d 6d 65 74 61 29 29 0a 09 6d (get-meta))..m
2fd0: 65 74 61 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 eta)))..(define
2fe0: 28 74 74 3a 77 61 69 74 2d 6f 6e 2d 73 65 72 76 (tt:wait-on-serv
2ff0: 65 72 2d 6c 6f 61 64 20 72 75 6e 2d 69 64 20 74 er-load run-id t
3000: 74 64 61 74 29 0a 20 20 28 69 66 20 74 74 64 61 tdat). (if ttda
3010: 74 20 3b 3b 20 69 66 20 6e 6f 20 73 65 72 76 65 t ;; if no serve
3020: 72 20 79 65 74 20 6a 75 73 74 20 70 61 73 73 20 r yet just pass
3030: 6f 6e 20 74 68 72 6f 75 67 68 0a 20 20 20 20 20 on through.
3040: 20 28 6c 65 74 2a 20 28 28 64 62 66 6e 61 6d 65 (let* ((dbfname
3050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3060: 20 28 64 62 6d 6f 64 3a 72 75 6e 2d 69 64 2d 3e (dbmod:run-id->
3070: 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 29 29 dbfname run-id))
3080: 0a 09 20 20 20 20 20 28 67 65 74 2d 6c 6f 77 65 .. (get-lowe
3090: 73 74 2d 74 68 72 65 61 64 2d 6c 6f 61 64 0a 09 st-thread-load..
30a0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
30b0: 0a 09 09 28 6c 65 74 2a 20 28 28 73 64 61 74 73 ...(let* ((sdats
30c0: 20 28 74 74 3a 67 65 74 2d 73 65 72 76 65 72 2d (tt:get-server-
30d0: 69 6e 66 6f 2d 73 6f 72 74 65 64 20 74 74 64 61 info-sorted ttda
30e0: 74 20 64 62 66 6e 61 6d 65 29 29 29 0a 09 09 20 t dbfname)))...
30f0: 20 28 63 61 72 20 28 6d 61 70 20 74 74 3a 67 65 (car (map tt:ge
3100: 74 2d 73 65 72 76 65 72 2d 74 68 72 65 61 64 73 t-server-threads
3110: 20 73 64 61 74 73 29 29 29 29 29 29 0a 09 28 69 sdats))))))..(i
3120: 66 20 74 74 64 61 74 0a 09 20 20 20 20 28 6c 65 f ttdat.. (le
3130: 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 t loop ((count 0
3140: 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 )).. (let*
3150: 28 28 6c 6f 77 65 73 74 6c 6f 61 64 20 28 67 65 ((lowestload (ge
3160: 74 2d 6c 6f 77 65 73 74 2d 74 68 72 65 61 64 2d t-lowest-thread-
3170: 6c 6f 61 64 29 29 29 0a 09 09 28 69 66 20 28 3e load)))...(if (>
3180: 20 6c 6f 77 65 73 74 6c 6f 61 64 20 35 29 20 3b lowestload 5) ;
3190: 3b 20 6c 6f 61 64 20 69 73 20 70 72 65 74 74 79 ; load is pretty
31a0: 20 68 69 67 68 0a 09 09 20 20 20 20 28 62 65 67 high... (beg
31b0: 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 in... (debu
31c0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
31d0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 lt-log-port* "Se
31e0: 72 76 65 72 73 20 61 70 70 65 61 72 20 6f 76 65 rvers appear ove
31f0: 72 6c 6f 61 64 65 64 20 77 69 74 68 20 22 6c 6f rloaded with "lo
3200: 77 65 73 74 6c 6f 61 64 22 20 74 68 72 65 61 64 westload" thread
3210: 73 2c 20 77 61 69 74 69 6e 67 2e 2e 2e 22 29 0a s, waiting...").
3220: 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
3230: 73 6c 65 65 70 21 20 31 29 0a 09 09 20 20 20 20 sleep! 1)...
3240: 20 20 28 69 66 20 28 3c 20 63 6f 75 6e 74 20 31 (if (< count 1
3250: 30 29 0a 09 09 09 20 20 28 6c 6f 6f 70 20 28 2b 0).... (loop (+
3260: 20 63 6f 75 6e 74 20 31 29 29 29 29 29 29 29 0a count 1))))))).
3270: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3280: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3290: 2d 70 6f 72 74 2a 20 22 43 61 6e 27 74 20 77 61 -port* "Can't wa
32a0: 69 74 20 6f 6e 20 73 65 72 76 65 72 20 6c 6f 61 it on server loa
32b0: 64 2c 20 2a 74 74 64 61 74 2a 20 6e 6f 74 20 73 d, *ttdat* not s
32c0: 65 74 22 29 29 29 29 29 0a 0a 28 64 65 66 69 6e et")))))..(defin
32d0: 65 20 28 74 74 3a 70 69 6e 67 20 68 6f 73 74 20 e (tt:ping host
32e0: 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 20 23 port server-id #
32f0: 21 6f 70 74 69 6f 6e 61 6c 20 28 74 72 69 65 73 !optional (tries
3300: 2d 6c 65 66 74 20 35 29 29 0a 20 20 28 6c 65 74 -left 5)). (let
3310: 2a 20 20 28 28 72 65 73 20 20 20 20 20 20 28 74 * ((res (t
3320: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 64 t:send-receive-d
3330: 69 72 65 63 74 20 68 6f 73 74 20 70 6f 72 74 20 irect host port
3340: 60 28 70 69 6e 67 20 23 66 20 23 66 20 23 66 29 `(ping #f #f #f)
3350: 20 70 69 6e 67 2d 6d 6f 64 65 3a 20 23 74 29 29 ping-mode: #t))
3360: 20 3b 3b 20 70 6c 65 61 73 65 20 73 65 6e 64 20 ;; please send
3370: 6d 65 20 79 6f 75 72 20 73 65 72 76 65 72 2d 69 me your server-i
3380: 64 0a 09 20 20 28 74 72 79 2d 61 67 61 69 6e 20 d.. (try-again
3390: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 (lambda ()...
33a0: 20 20 20 20 28 69 66 20 28 3e 20 74 72 69 65 73 (if (> tries
33b0: 2d 6c 65 66 74 20 30 29 0a 09 09 09 20 20 20 28 -left 0).... (
33c0: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 28 74 begin.... (t
33d0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
33e0: 09 09 09 20 20 20 20 20 28 74 74 3a 70 69 6e 67 ... (tt:ping
33f0: 20 68 6f 73 74 20 70 6f 72 74 20 73 65 72 76 65 host port serve
3400: 72 2d 69 64 20 28 2d 20 74 72 69 65 73 2d 6c 65 r-id (- tries-le
3410: 66 74 20 31 29 29 29 0a 09 09 09 20 20 20 23 66 ft 1))).... #f
3420: 29 29 29 29 0a 20 20 20 20 3b 3b 0a 20 20 20 20 )))). ;;.
3430: 3b 3b 20 6e 65 65 64 20 74 77 6f 20 74 68 72 65 ;; need two thre
3440: 61 64 73 2c 20 6f 6e 65 20 61 20 35 20 73 65 63 ads, one a 5 sec
3450: 6f 6e 64 20 74 69 6d 65 72 0a 20 20 20 20 3b 3b ond timer. ;;
3460: 0a 20 20 20 20 28 6d 61 74 63 68 20 72 65 73 0a . (match res.
3470: 20 20 20 20 20 20 28 28 73 74 61 74 75 73 20 65 ((status e
3480: 72 72 6d 73 67 20 72 65 73 75 6c 74 20 6d 65 74 rrmsg result met
3490: 61 29 0a 20 20 20 20 20 20 20 28 74 74 3a 73 61 a). (tt:sa
34a0: 76 65 2d 73 65 72 76 65 72 2d 6d 65 74 61 20 68 ve-server-meta h
34b0: 6f 73 74 20 70 6f 72 74 20 6d 65 74 61 29 0a 20 ost port meta).
34c0: 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c (if (equal
34d0: 3f 20 72 65 73 75 6c 74 20 73 65 72 76 65 72 2d ? result server-
34e0: 69 64 29 0a 09 20 20 20 28 6c 65 74 2a 20 28 28 id).. (let* ((
34f0: 73 65 72 76 65 72 2d 73 74 61 74 65 20 28 61 6c server-state (al
3500: 69 73 74 2d 72 65 66 20 27 73 73 74 61 74 65 20 ist-ref 'sstate
3510: 6d 65 74 61 29 29 29 0a 09 20 20 20 20 20 3b 3b meta))).. ;;
3520: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
3530: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3540: 74 2a 20 22 50 69 6e 67 20 74 6f 20 22 68 6f 73 t* "Ping to "hos
3550: 74 22 3a 22 70 6f 72 74 22 20 73 75 63 63 65 73 t":"port" succes
3560: 73 66 75 6c 2e 22 29 0a 09 20 20 20 20 20 28 6f sful.").. (o
3570: 72 20 73 65 72 76 65 72 2d 73 74 61 74 65 20 27 r server-state '
3580: 75 6e 6b 29 29 20 3b 3b 20 74 68 65 6e 20 77 65 unk)) ;; then we
3590: 20 61 72 65 20 67 6f 6f 64 0a 09 20 20 20 28 62 are good.. (b
35a0: 65 67 69 6e 0a 09 20 20 20 20 20 28 69 66 20 73 egin.. (if s
35b0: 65 72 76 65 72 2d 69 64 0a 09 09 20 28 64 65 62 erver-id... (deb
35c0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
35d0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
35e0: 41 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 2d 69 ARNING: server-i
35f0: 64 20 64 6f 65 73 20 6e 6f 74 20 6d 61 74 63 68 d does not match
3600: 2c 20 65 78 70 65 63 74 65 64 3a 20 22 73 65 72 , expected: "ser
3610: 76 65 72 2d 69 64 22 2c 20 67 6f 74 3a 20 22 72 ver-id", got: "r
3620: 65 73 75 6c 74 29 29 0a 09 20 20 20 20 20 23 66 esult)).. #f
3630: 29 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 0a ))). (else.
3640: 20 20 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 ;; (debug
3650: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
3660: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 73 t-log-port* "res
3670: 20 6e 6f 74 20 69 6e 20 66 6f 72 6d 20 28 73 74 not in form (st
3680: 61 74 75 73 20 65 72 72 6d 73 67 20 72 65 73 75 atus errmsg resu
3690: 6c 74 20 6d 65 74 61 29 2c 20 67 6f 74 3a 20 22 lt meta), got: "
36a0: 72 65 73 29 0a 20 20 20 20 20 20 20 28 74 72 79 res). (try
36b0: 2d 61 67 61 69 6e 29 29 29 29 29 0a 0a 3b 3b 20 -again)))))..;;
36c0: 63 6c 69 65 6e 74 20 73 69 64 65 20 68 61 6e 64 client side hand
36d0: 6c 65 72 0a 3b 3b 0a 3b 3b 28 74 74 3a 68 61 6e ler.;;.;;(tt:han
36e0: 64 6c 65 72 20 23 3c 74 74 3e 20 67 65 74 2d 6b dler #<tt> get-k
36f0: 65 79 73 20 23 66 20 28 29 20 32 20 23 66 20 22 eys #f () 2 #f "
3700: 2f 68 6f 6d 65 2f 6d 61 74 74 2f 64 61 74 61 2f /home/matt/data/
3710: 6d 65 67 61 74 65 73 74 2f 65 78 74 2d 74 65 73 megatest/ext-tes
3720: 74 73 22 20 23 66 20 22 6d 61 69 6e 2e 64 62 22 ts" #f "main.db"
3730: 20 22 65 78 74 2d 74 65 73 74 73 22 20 22 2f 68 "ext-tests" "/h
3740: 6f 6d 65 2f 6d 61 74 74 2f 64 61 74 61 2f 6d 65 ome/matt/data/me
3750: 67 61 74 65 73 74 2f 62 69 6e 2f 2e 32 32 2e 30 gatest/bin/.22.0
3760: 34 2f 2e 2e 2f 6d 65 67 61 74 65 73 74 22 29 0a 4/../megatest").
3770: 3b 3b 67 0a 28 64 65 66 69 6e 65 20 28 74 74 3a ;;g.(define (tt:
3780: 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d handler ttdat cm
3790: 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 d run-id params
37a0: 61 74 74 65 6d 70 74 6e 75 6d 20 72 65 61 64 6f attemptnum reado
37b0: 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 nly-mode dbfname
37c0: 20 74 65 73 74 73 75 69 74 65 20 6d 74 65 78 65 testsuite mtexe
37d0: 20 73 65 72 76 65 72 2d 73 74 61 72 74 2d 70 72 server-start-pr
37e0: 6f 63 29 0a 20 20 3b 3b 20 63 6f 6e 6e 65 63 74 oc). ;; connect
37f0: 2d 74 6f 2d 73 65 72 76 65 72 20 77 69 6c 6c 20 -to-server will
3800: 73 74 61 72 74 20 61 20 73 65 72 76 65 72 20 69 start a server i
3810: 66 20 6e 65 65 64 65 64 2e 0a 20 20 28 6c 65 74 f needed.. (let
3820: 2a 20 28 28 61 72 65 61 70 61 74 68 20 28 74 74 * ((areapath (tt
3830: 2d 61 72 65 61 70 61 74 68 20 74 74 64 61 74 29 -areapath ttdat)
3840: 29 0a 09 20 28 63 6f 6e 6e 20 20 20 20 20 28 74 ).. (conn (t
3850: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
3860: 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 64 61 74 -to-server ttdat
3870: 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 dbfname run-id
3880: 74 65 73 74 73 75 69 74 65 20 73 65 72 76 65 72 testsuite server
3890: 2d 73 74 61 72 74 2d 70 72 6f 63 29 29 29 20 3b -start-proc))) ;
38a0: 3b 20 6c 6f 6f 6b 73 20 75 70 20 63 6f 6e 6e 20 ; looks up conn
38b0: 6b 65 79 65 64 20 62 79 20 64 62 66 6e 61 6d 65 keyed by dbfname
38c0: 0a 20 20 20 20 28 69 66 20 63 6f 6e 6e 0a 09 3b . (if conn..;
38d0: 3b 20 68 61 76 65 20 63 6f 6e 6e 65 63 74 69 6f ; have connectio
38e0: 6e 2c 20 63 61 6c 6c 20 74 68 65 20 73 65 72 76 n, call the serv
38f0: 65 72 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 20 er..(let* ((res
3900: 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 (tt:send-receive
3910: 20 74 74 64 61 74 20 63 6f 6e 6e 20 63 6d 64 20 ttdat conn cmd
3920: 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 29 29 run-id params)))
3930: 0a 09 20 20 3b 3b 20 72 65 73 20 69 73 20 28 73 .. ;; res is (s
3940: 74 61 74 75 73 20 65 72 72 6d 73 67 20 72 65 73 tatus errmsg res
3950: 75 6c 74 20 6d 65 74 61 29 0a 09 20 20 28 6d 61 ult meta).. (ma
3960: 74 63 68 20 72 65 73 0a 09 20 20 20 20 28 28 73 tch res.. ((s
3970: 74 61 74 75 73 20 65 72 72 6d 73 67 20 72 65 73 tatus errmsg res
3980: 75 6c 74 20 6d 65 74 61 29 0a 09 20 20 20 20 20 ult meta)..
3990: 28 69 66 20 28 6c 69 73 74 3f 20 6d 65 74 61 29 (if (list? meta)
39a0: 0a 09 09 20 28 6c 65 74 2a 20 28 28 64 65 6c 61 ... (let* ((dela
39b0: 79 2d 77 61 69 74 20 28 61 6c 69 73 74 2d 72 65 y-wait (alist-re
39c0: 66 20 27 64 65 6c 61 79 2d 77 61 69 74 20 6d 65 f 'delay-wait me
39d0: 74 61 29 29 29 0a 09 09 20 20 20 28 69 66 20 28 ta)))... (if (
39e0: 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 64 65 6c and (number? del
39f0: 61 79 2d 77 61 69 74 29 0a 09 09 09 20 20 20 20 ay-wait)....
3a00: 28 3e 20 64 65 6c 61 79 2d 77 61 69 74 20 30 29 (> delay-wait 0)
3a10: 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 69 )... (begi
3a20: 6e 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 n.... (debug:pri
3a30: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
3a40: 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 g-port* "Server
3a50: 69 73 20 6c 6f 61 64 65 64 2c 20 64 65 6c 61 79 is loaded, delay
3a60: 69 6e 67 20 22 64 65 6c 61 79 2d 77 61 69 74 22 ing "delay-wait"
3a70: 20 73 65 63 6f 6e 64 73 22 29 0a 09 09 09 20 28 seconds").... (
3a80: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 64 65 thread-sleep! de
3a90: 6c 61 79 2d 77 61 69 74 29 29 29 29 29 0a 09 20 lay-wait)))))..
3aa0: 20 20 20 20 28 63 61 73 65 20 73 74 61 74 75 73 (case status
3ab0: 0a 09 20 20 20 20 20 20 20 28 28 62 75 73 79 29 .. ((busy)
3ac0: 20 3b 3b 20 72 65 73 75 6c 74 20 77 69 6c 6c 20 ;; result will
3ad0: 62 65 20 68 6f 77 20 6c 6f 6e 67 20 74 68 65 20 be how long the
3ae0: 73 65 72 76 65 72 20 77 61 6e 74 73 20 79 6f 75 server wants you
3af0: 20 74 6f 20 64 65 6c 61 79 0a 09 09 28 6c 65 74 to delay...(let
3b00: 2a 20 28 28 72 61 77 2d 64 6c 79 20 20 28 69 66 * ((raw-dly (if
3b10: 20 28 6e 75 6d 62 65 72 3f 20 72 65 73 75 6c 74 (number? result
3b20: 29 20 72 65 73 75 6c 74 20 30 2e 31 29 29 0a 09 ) result 0.1))..
3b30: 09 20 20 20 20 20 20 20 28 64 6c 79 20 20 20 20 . (dly
3b40: 20 20 28 2b 20 72 61 77 2d 64 6c 79 20 28 2f 20 (+ raw-dly (/
3b50: 61 74 74 65 6d 70 74 6e 75 6d 20 31 30 29 29 29 attemptnum 10)))
3b60: 29 20 3b 3b 20 28 2a 20 72 61 77 2d 64 6c 79 20 ) ;; (* raw-dly
3b70: 28 2f 20 61 74 74 65 6d 70 74 6e 75 6d 20 32 29 (/ attemptnum 2)
3b80: 29 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 )))... (debug:p
3b90: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
3ba0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
3bb0: 4e 47 3a 20 73 65 72 76 65 72 20 66 6f 72 20 22 NG: server for "
3bc0: 64 62 66 6e 61 6d 65 22 20 69 73 20 62 75 73 79 dbfname" is busy
3bd0: 2c 20 63 6d 64 20 69 73 20 22 63 6d 64 22 2c 20 , cmd is "cmd",
3be0: 77 69 6c 6c 20 74 72 79 20 61 67 61 69 6e 20 69 will try again i
3bf0: 6e 20 22 64 6c 79 22 20 73 65 63 6f 6e 64 73 2e n "dly" seconds.
3c00: 20 54 68 69 73 20 69 73 20 61 74 74 65 6d 70 74 This is attempt
3c10: 20 22 28 2d 20 61 74 74 65 6d 70 74 6e 75 6d 20 "(- attemptnum
3c20: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
3c30: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3c40: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
3c50: 67 2d 70 6f 72 74 2a 20 65 72 72 6d 73 67 29 0a g-port* errmsg).
3c60: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
3c70: 70 21 20 64 6c 79 29 0a 09 09 20 20 28 74 74 3a p! dly)... (tt:
3c80: 68 61 6e 64 6c 65 72 20 20 74 74 64 61 74 20 63 handler ttdat c
3c90: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
3ca0: 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 (+ attemptnum 1
3cb0: 29 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 ) readonly-mode
3cc0: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
3cd0: 65 20 6d 74 65 78 65 20 73 65 72 76 65 72 2d 73 e mtexe server-s
3ce0: 74 61 72 74 2d 70 72 6f 63 29 29 29 0a 09 20 20 tart-proc)))..
3cf0: 20 20 20 20 20 28 28 6c 6f 61 64 65 64 29 0a 09 ((loaded)..
3d00: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
3d10: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3d20: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 65 72 t* "WARNING: ser
3d30: 76 65 72 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 ver for "dbfname
3d40: 22 20 69 73 20 6c 6f 61 64 65 64 2c 20 73 6c 6f " is loaded, slo
3d50: 77 69 6e 67 20 71 75 65 72 69 65 73 2e 22 29 0a wing queries.").
3d60: 09 09 28 74 74 3a 62 61 63 6b 6f 66 66 2d 69 6e ..(tt:backoff-in
3d70: 63 72 20 28 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 cr (tt-conn-host
3d80: 20 63 6f 6e 6e 29 28 74 74 2d 63 6f 6e 6e 2d 70 conn)(tt-conn-p
3d90: 6f 72 74 20 63 6f 6e 6e 29 29 0a 0a 09 09 3b 3b ort conn))....;;
3da0: 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 61 this would be a
3db0: 20 67 6f 6f 64 20 70 6c 61 63 65 20 74 6f 20 66 good place to f
3dc0: 6f 72 63 65 20 72 65 63 6f 6e 6e 65 63 74 69 6f orce reconnectio
3dd0: 6e 20 61 6e 64 20 63 6f 6e 6e 65 63 74 20 74 6f n and connect to
3de0: 20 61 20 64 69 66 66 65 72 65 6e 74 20 73 65 72 a different ser
3df0: 76 65 72 0a 09 09 0a 09 09 72 65 73 75 6c 74 29 ver......result)
3e00: 20 3b 3b 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 ;; (tt:handler
3e10: 20 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 ttdat cmd run-i
3e20: 64 20 70 61 72 61 6d 73 20 28 2b 20 61 74 74 65 d params (+ atte
3e30: 6d 70 74 6e 75 6d 20 31 29 20 72 65 61 64 6f 6e mptnum 1) readon
3e40: 6c 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 ly-mode dbfname
3e50: 74 65 73 74 73 75 69 74 65 20 6d 74 65 78 65 29 testsuite mtexe)
3e60: 29 0a 09 20 20 20 20 20 20 20 28 65 6c 73 65 0a ).. (else.
3e70: 09 09 72 65 73 75 6c 74 29 29 29 0a 09 20 20 20 ..result)))..
3e80: 20 28 65 6c 73 65 20 3b 3b 20 64 69 64 20 6e 6f (else ;; did no
3e90: 74 20 72 65 63 65 69 76 65 20 70 72 6f 70 65 72 t receive proper
3ea0: 6c 79 20 66 6f 72 6d 61 74 65 64 20 72 65 73 75 ly formated resu
3eb0: 6c 74 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f lt.. (if (no
3ec0: 74 20 72 65 73 29 20 3b 3b 20 74 74 3a 73 65 6e t res) ;; tt:sen
3ed0: 64 2d 72 65 63 65 69 76 65 20 74 65 6c 6c 69 6e d-receive tellin
3ee0: 67 20 75 73 20 74 68 61 74 20 63 6f 6d 6d 75 6e g us that commun
3ef0: 69 63 61 74 69 6f 6e 20 66 61 69 6c 65 64 0a 09 ication failed..
3f00: 09 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 20 20 . (let* ((host
3f10: 20 20 28 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 20 (tt-conn-host
3f20: 63 6f 6e 6e 29 29 0a 09 09 09 28 70 6f 72 74 20 conn))....(port
3f30: 20 20 20 28 74 74 2d 63 6f 6e 6e 2d 70 6f 72 74 (tt-conn-port
3f40: 20 63 6f 6e 6e 29 29 0a 09 09 09 3b 3b 20 28 64 conn))....;; (d
3f50: 62 66 6e 61 6d 65 20 28 74 74 2d 63 6f 6e 6e 2d bfname (tt-conn-
3f60: 70 6f 72 74 20 63 6f 6e 6e 29 29 20 3b 3b 20 31 port conn)) ;; 1
3f70: 39 32 2e 31 36 38 2e 30 2e 31 32 37 3a 34 32 34 92.168.0.127:424
3f80: 32 2d 37 32 36 39 32 34 3a 34 2e 64 62 0a 09 09 2-726924:4.db...
3f90: 09 28 70 69 64 20 20 20 20 20 28 74 74 2d 63 6f .(pid (tt-co
3fa0: 6e 6e 2d 70 69 64 20 20 63 6f 6e 6e 29 29 0a 20 nn-pid conn)).
3fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3fc0: 20 20 20 20 20 20 20 3b 3b 28 73 65 72 76 69 6e ;;(servin
3fd0: 66 20 28 74 74 2d 63 6f 6e 6e 2d 73 65 72 76 69 f (tt-conn-servi
3fe0: 6e 66 2d 66 69 6c 65 20 63 6f 6e 6e 29 29 29 20 nf-file conn)))
3ff0: 0a 09 09 09 28 73 65 72 76 69 6e 66 20 28 74 74 ....(servinf (tt
4000: 2d 73 65 72 76 69 6e 66 2d 66 69 6c 65 20 74 74 -servinf-file tt
4010: 64 61 74 29 29 29 20 3b 3b 20 28 63 6f 6e 63 20 dat))) ;; (conc
4020: 61 72 65 61 70 61 74 68 22 2f 2e 73 65 72 76 69 areapath"/.servi
4030: 6e 66 6f 2f 22 68 6f 73 74 22 3a 22 70 6f 72 74 nfo/"host":"port
4040: 22 2d 22 70 69 64 22 3a 22 64 62 66 6e 61 6d 65 "-"pid":"dbfname
4050: 29 29 29 20 3b 3b 20 54 4f 44 4f 2c 20 75 73 65 ))) ;; TODO, use
4060: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 73 65 72 (server:get-ser
4070: 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 61 vinfo-dir areapa
4080: 74 68 29 0a 09 09 20 20 20 28 68 61 73 68 2d 74 th)... (hash-t
4090: 61 62 6c 65 2d 73 65 74 21 20 28 74 74 2d 63 6f able-set! (tt-co
40a0: 6e 6e 73 20 74 74 64 61 74 29 20 64 62 66 6e 61 nns ttdat) dbfna
40b0: 6d 65 20 23 66 29 20 3b 3b 20 63 6c 65 61 72 20 me #f) ;; clear
40c0: 6f 75 74 20 74 68 65 20 63 6f 6e 6e 20 66 6f 72 out the conn for
40d0: 20 74 68 69 73 20 64 62 66 6e 61 6d 65 20 74 6f this dbfname to
40e0: 20 66 6f 72 63 65 20 66 69 6e 64 69 6e 67 20 6e force finding n
40f0: 65 77 20 73 65 72 76 65 72 0a 09 09 20 20 20 28 ew server... (
4100: 69 66 20 28 61 6e 64 20 73 65 72 76 69 6e 66 20 if (and servinf
4110: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 65 (file-exists? se
4120: 72 76 69 6e 66 29 29 0a 09 09 20 20 20 20 20 20 rvinf))...
4130: 20 28 62 65 67 69 6e 0a 09 09 09 20 28 69 66 20 (begin.... (if
4140: 28 3c 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 30 (< attemptnum 10
4150: 29 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 6e ).... (begin
4160: 0a 09 09 09 20 20 20 20 20 20 20 28 74 68 72 65 .... (thre
4170: 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 0a 09 ad-sleep! 0.5)..
4180: 09 09 20 20 20 20 20 20 20 28 74 74 3a 68 61 6e .. (tt:han
4190: 64 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 dler ttdat cmd r
41a0: 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 2b 20 un-id params (+
41b0: 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 72 65 attemptnum 1) re
41c0: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e adonly-mode dbfn
41d0: 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d 74 ame testsuite mt
41e0: 65 78 65 20 73 65 72 76 65 72 2d 73 74 61 72 74 exe server-start
41f0: 2d 70 72 6f 63 29 29 0a 09 09 09 20 20 20 20 20 -proc))....
4200: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 (begin....
4210: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
4220: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
4230: 74 2a 20 22 49 4e 46 4f 3a 20 6e 6f 20 72 65 73 t* "INFO: no res
4240: 70 6f 6e 73 65 20 66 72 6f 6d 20 73 65 72 76 65 ponse from serve
4250: 72 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 20 r "host":"port"
4260: 66 6f 72 20 22 64 62 66 6e 61 6d 65 29 0a 09 09 for "dbfname)...
4270: 09 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 . (if (and
4280: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 (file-exists? s
4290: 65 72 76 69 6e 66 29 0a 09 09 09 09 09 28 3e 20 ervinf)......(>
42a0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
42b0: 6e 64 73 29 28 66 69 6c 65 2d 6d 6f 64 69 66 69 nds)(file-modifi
42c0: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 65 72 76 cation-time serv
42d0: 69 6e 66 29 29 20 36 30 29 29 0a 09 09 09 09 20 inf)) 60)).....
42e0: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
42f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
4300: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4310: 72 74 2a 20 22 49 4e 46 4f 3a 20 22 73 65 72 76 rt* "INFO: "serv
4320: 69 6e 66 22 20 66 69 6c 65 20 73 65 65 6d 73 20 inf" file seems
4330: 6f 6c 64 20 61 6e 64 20 6e 6f 20 70 69 6e 67 20 old and no ping
4340: 72 65 73 70 6f 6e 73 65 2c 20 72 65 6d 6f 76 69 response, removi
4350: 6e 67 20 69 74 2e 22 29 0a 09 09 09 09 20 20 20 ng it.").....
4360: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
4370: 69 6f 6e 73 0a 09 09 09 09 09 20 65 78 6e 0a 09 ions...... exn..
4380: 09 09 09 20 20 20 20 20 20 20 23 66 0a 09 09 09 ... #f....
4390: 09 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d . (delete-
43a0: 66 69 6c 65 2a 20 73 65 72 76 69 6e 66 29 29 0a file* servinf)).
43b0: 09 09 09 09 20 20 20 20 20 28 74 74 3a 68 61 6e .... (tt:han
43c0: 64 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 dler ttdat cmd r
43d0: 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 2b 20 un-id params (+
43e0: 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 72 65 attemptnum 1) re
43f0: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e adonly-mode dbfn
4400: 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d 74 ame testsuite mt
4410: 65 78 65 20 73 65 72 76 65 72 2d 73 74 61 72 74 exe server-start
4420: 2d 70 72 6f 63 29 29 0a 09 09 09 09 20 20 20 28 -proc))..... (
4430: 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 3b begin..... ;
4440: 3b 20 73 74 61 72 74 20 73 65 72 76 65 72 20 2d ; start server -
4450: 20 61 64 64 72 65 73 73 65 64 20 69 6e 20 63 6c addressed in cl
4460: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d ient-connect-to-
4470: 73 65 72 76 65 72 0a 09 09 09 09 20 20 20 20 20 server.....
4480: 3b 3b 20 64 65 6c 61 79 20 20 20 20 20 20 20 20 ;; delay
4490: 2d 20 61 64 64 72 65 73 73 65 64 20 69 6e 20 63 - addressed in c
44a0: 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f lient-connect-to
44b0: 2d 73 65 72 76 65 72 0a 09 09 09 09 20 20 20 20 -server.....
44c0: 20 3b 3b 20 74 72 79 20 61 67 61 69 6e 0a 09 09 ;; try again...
44d0: 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 .. (thread-s
44e0: 6c 65 65 70 21 20 30 2e 32 35 29 20 3b 3b 20 64 leep! 0.25) ;; d
44f0: 75 6e 6e 6f 2c 20 49 20 74 68 69 6e 6b 20 74 68 unno, I think th
4500: 69 73 20 6e 65 65 64 73 20 74 6f 20 62 65 20 68 is needs to be h
4510: 65 72 65 0a 09 09 09 09 20 20 20 20 20 28 74 74 ere..... (tt
4520: 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 :handler ttdat c
4530: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
4540: 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 (+ attemptnum 1
4550: 29 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 ) readonly-mode
4560: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
4570: 65 20 6d 74 65 78 65 20 73 65 72 76 65 72 2d 73 e mtexe server-s
4580: 74 61 72 74 2d 70 72 6f 63 29 29 0a 09 09 09 09 tart-proc)).....
4590: 20 20 20 29 29 29 29 0a 09 09 20 20 20 20 20 20 ))))...
45a0: 20 28 62 65 67 69 6e 20 3b 3b 20 6e 6f 20 73 65 (begin ;; no se
45b0: 72 76 65 72 20 66 69 6c 65 2c 20 64 65 6c 61 79 rver file, delay
45c0: 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e 0a 09 and try again..
45d0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
45e0: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
45f0: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 63 6f 6e 6e ort* "INFO: conn
4600: 65 63 74 69 6f 6e 20 74 6f 20 73 65 72 76 65 72 ection to server
4610: 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 20 62 "host":"port" b
4620: 72 6f 6b 65 6e 20 66 6f 72 20 22 64 62 66 6e 61 roken for "dbfna
4630: 6d 65 22 2c 20 6e 6f 20 73 65 72 76 69 6e 66 20 me", no servinf
4640: 66 69 6c 65 2e 20 53 65 72 76 65 72 20 65 78 69 file. Server exi
4650: 74 65 64 3f 20 22 29 0a 09 09 09 20 28 74 68 72 ted? ").... (thr
4660: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 0a ead-sleep! 0.5).
4670: 09 09 09 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 ... (tt:handler
4680: 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 64 ttdat cmd run-id
4690: 20 70 61 72 61 6d 73 20 28 2b 20 61 74 74 65 6d params (+ attem
46a0: 70 74 6e 75 6d 20 31 29 20 72 65 61 64 6f 6e 6c ptnum 1) readonl
46b0: 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 y-mode dbfname t
46c0: 65 73 74 73 75 69 74 65 20 6d 74 65 78 65 20 73 estsuite mtexe s
46d0: 65 72 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 erver-start-proc
46e0: 29 29 29 29 0a 09 09 20 28 62 65 67 69 6e 20 3b ))))... (begin ;
46f0: 3b 20 74 68 69 73 20 63 61 73 65 20 69 73 20 77 ; this case is w
4700: 68 65 72 65 20 72 65 73 20 69 73 20 6d 61 6c 66 here res is malf
4710: 6f 72 6d 65 64 2e 20 50 72 6f 62 61 62 6c 79 20 ormed. Probably
4720: 73 68 6f 75 6c 64 20 61 62 6f 72 74 0a 09 09 20 should abort...
4730: 20 20 28 61 73 73 65 72 74 20 23 66 20 22 46 41 (assert #f "FA
4740: 54 41 4c 3a 20 74 74 3a 68 61 6e 64 6c 65 72 20 TAL: tt:handler
4750: 72 65 63 65 69 76 65 64 20 62 61 64 20 64 61 74 received bad dat
4760: 61 20 22 72 65 73 29 0a 09 09 20 20 20 3b 3b 20 a "res)... ;;
4770: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
4780: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4790: 2a 20 22 49 4e 46 4f 3a 20 67 6f 74 20 63 6f 72 * "INFO: got cor
47a0: 72 75 70 74 20 64 61 74 61 20 66 72 6f 6d 20 73 rupt data from s
47b0: 65 72 76 65 72 20 22 68 6f 73 74 22 3a 22 70 6f erver "host":"po
47c0: 72 74 22 2c 20 22 72 65 73 22 2c 20 66 6f 72 20 rt", "res", for
47d0: 22 64 62 66 6e 61 6d 65 22 2c 20 77 69 6c 6c 20 "dbfname", will
47e0: 74 72 79 20 61 67 61 69 6e 2e 22 29 0a 09 09 20 try again.")...
47f0: 20 20 3b 3b 20 28 74 74 3a 68 61 6e 64 6c 65 72 ;; (tt:handler
4800: 20 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 ttdat cmd run-i
4810: 64 20 70 61 72 61 6d 73 20 28 2b 20 61 74 74 65 d params (+ atte
4820: 6d 70 74 6e 75 6d 20 31 29 20 72 65 61 64 6f 6e mptnum 1) readon
4830: 6c 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 ly-mode dbfname
4840: 74 65 73 74 73 75 69 74 65 20 6d 74 65 78 65 29 testsuite mtexe)
4850: 0a 09 09 20 20 20 29 29 29 29 29 0a 09 28 62 65 ... )))))..(be
4860: 67 69 6e 0a 09 20 20 28 74 68 72 65 61 64 2d 73 gin.. (thread-s
4870: 6c 65 65 70 21 20 31 29 20 3b 3b 20 6e 6f 20 63 leep! 1) ;; no c
4880: 6f 6e 6e 20 79 65 74 20 73 65 74 20 75 70 2c 20 onn yet set up,
4890: 67 69 76 65 20 69 74 20 61 20 72 65 73 74 20 61 give it a rest a
48a0: 6e 64 20 74 72 79 20 61 67 61 69 6e 0a 09 20 20 nd try again..
48b0: 28 74 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 (tt:handler ttda
48c0: 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 t cmd run-id par
48d0: 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 20 72 ams attemptnum r
48e0: 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 eadonly-mode dbf
48f0: 6e 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d name testsuite m
4900: 74 65 78 65 20 73 65 72 76 65 72 2d 73 74 61 72 texe server-star
4910: 74 2d 70 72 6f 63 29 29 29 29 29 0a 0a 3b 3b 20 t-proc)))))..;;
4920: 67 65 74 73 20 73 65 72 76 65 72 20 69 6e 66 6f gets server info
4930: 20 61 6e 64 20 61 70 70 65 6e 64 73 20 70 61 74 and appends pat
4940: 68 20 74 6f 20 73 65 72 76 65 72 20 66 69 6c 65 h to server file
4950: 0a 3b 3b 20 73 6f 72 74 73 20 62 79 20 61 67 65 .;; sorts by age
4960: 2c 20 2d 2d 6f 6c 64 65 73 74 2d 2d 20 6e 6f 77 , --oldest-- now
4970: 20 6e 65 77 65 73 74 20 66 69 72 73 74 0a 3b 3b newest first.;;
4980: 0a 3b 3b 20 6d 6f 76 65 20 74 68 65 20 70 69 6e .;; move the pin
4990: 67 20 68 65 72 65 3f 0a 3b 3b 0a 3b 3b 20 72 65 g here?.;;.;; re
49a0: 74 75 72 6e 73 20 6c 69 73 74 20 6f 66 20 28 68 turns list of (h
49b0: 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 73 65 ost port startse
49c0: 63 6f 6e 64 73 20 73 65 72 76 65 72 2d 69 64 20 conds server-id
49d0: 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a 3b 3b servinfofile).;;
49e0: 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 67 65 74 .(define (tt:get
49f0: 2d 73 65 72 76 65 72 2d 69 6e 66 6f 2d 73 6f 72 -server-info-sor
4a00: 74 65 64 20 74 74 64 61 74 20 64 62 66 6e 61 6d ted ttdat dbfnam
4a10: 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 72 65 e). (let* ((are
4a20: 61 70 61 74 68 20 28 74 74 2d 61 72 65 61 70 61 apath (tt-areapa
4a30: 74 68 20 74 74 64 61 74 29 29 0a 09 20 28 73 66 th ttdat)).. (sf
4a40: 69 6c 65 73 20 20 20 28 74 74 3a 66 69 6e 64 2d iles (tt:find-
4a50: 73 65 72 76 65 72 20 61 72 65 61 70 61 74 68 20 server areapath
4a60: 64 62 66 6e 61 6d 65 29 29 0a 09 20 28 73 64 61 dbfname)).. (sda
4a70: 74 73 20 20 20 20 28 66 69 6c 74 65 72 20 63 61 ts (filter ca
4a80: 72 20 28 6d 61 70 20 74 74 3a 73 65 72 76 65 72 r (map tt:server
4a90: 2d 67 65 74 2d 69 6e 66 6f 20 73 66 69 6c 65 73 -get-info sfiles
4aa0: 29 29 29 20 3b 3b 20 66 69 72 73 74 20 65 6c 65 ))) ;; first ele
4ab0: 6d 65 6e 74 20 69 73 20 23 66 20 69 66 20 74 68 ment is #f if th
4ac0: 65 20 66 69 6c 65 20 64 69 73 61 70 70 65 61 72 e file disappear
4ad0: 65 64 20 77 68 69 6c 65 20 62 65 69 6e 67 20 72 ed while being r
4ae0: 65 61 64 0a 09 20 28 73 6f 72 74 65 64 20 20 20 ead.. (sorted
4af0: 28 73 6f 72 74 20 73 64 61 74 73 20 28 6c 61 6d (sort sdats (lam
4b00: 62 64 61 20 28 61 20 62 29 0a 09 09 09 09 20 28 bda (a b)..... (
4b10: 6c 65 74 2a 20 28 28 73 74 61 72 74 61 20 28 6c let* ((starta (l
4b20: 69 73 74 2d 72 65 66 20 61 20 32 29 29 0a 09 09 ist-ref a 2))...
4b30: 09 09 09 28 73 74 61 72 74 62 20 28 6c 69 73 74 ...(startb (list
4b40: 2d 72 65 66 20 62 20 32 29 29 29 0a 09 09 09 09 -ref b 2))).....
4b50: 20 20 20 28 69 66 20 28 65 71 3f 20 73 74 61 72 (if (eq? star
4b60: 74 61 20 73 74 61 72 74 62 29 0a 09 09 09 09 20 ta startb).....
4b70: 20 20 20 20 20 20 28 73 74 72 69 6e 67 3e 3f 20 (string>?
4b80: 28 6c 69 73 74 2d 72 65 66 20 61 20 33 29 28 6c (list-ref a 3)(l
4b90: 69 73 74 2d 72 65 66 20 62 20 33 29 29 20 3b 3b ist-ref b 3)) ;;
4ba0: 20 69 66 20 73 65 72 76 65 72 73 20 73 74 61 72 if servers star
4bb0: 74 65 64 20 61 74 20 73 61 6d 65 20 74 69 6d 65 ted at same time
4bc0: 20 6c 6f 6f 6b 20 61 74 20 73 65 72 76 65 72 2d look at server-
4bd0: 69 64 0a 09 09 09 09 20 20 20 20 20 20 20 28 3e id..... (>
4be0: 20 73 74 61 72 74 61 20 73 74 61 72 74 62 29 29 starta startb))
4bf0: 29 29 29 29 0a 09 20 28 63 6f 75 6e 74 20 20 20 )))).. (count
4c00: 20 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 0)). (for-ea
4c10: 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
4c20: 28 72 65 63 29 0a 20 20 20 20 20 20 20 28 69 66 (rec). (if
4c30: 20 28 6f 72 20 28 3e 20 28 6c 65 6e 67 74 68 20 (or (> (length
4c40: 73 6f 72 74 65 64 29 20 31 29 0a 09 20 20 20 20 sorted) 1)..
4c50: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e (common:low-n
4c60: 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 22 oise-print 120 "
4c70: 73 65 72 76 65 72 20 69 6e 66 6f 20 73 6f 72 74 server info sort
4c80: 65 64 22 29 29 0a 09 20 20 20 28 64 65 62 75 67 ed")).. (debug
4c90: 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c :print 2 *defaul
4ca0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 45 52 t-log-port* "SER
4cb0: 56 45 52 20 23 22 63 6f 75 6e 74 22 3a 20 22 28 VER #"count": "(
4cc0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
4cd0: 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 73 6f 72 se (map conc sor
4ce0: 74 65 64 29 20 22 2c 20 22 29 29 29 0a 20 20 20 ted) ", "))).
4cf0: 20 20 20 20 28 73 65 74 21 20 63 6f 75 6e 74 20 (set! count
4d00: 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 0a 20 20 (+ count 1))).
4d10: 20 20 20 73 6f 72 74 65 64 29 0a 20 20 20 20 73 sorted). s
4d20: 6f 72 74 65 64 29 29 0a 20 20 20 20 0a 28 64 65 orted)). .(de
4d30: 66 69 6e 65 20 28 74 74 3a 73 65 6e 64 2d 72 65 fine (tt:send-re
4d40: 63 65 69 76 65 20 74 74 64 61 74 20 63 6f 6e 6e ceive ttdat conn
4d50: 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 cmd run-id para
4d60: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 6f ms). (let* ((ho
4d70: 73 74 2d 70 6f 72 74 20 28 74 74 2d 63 6f 6e 6e st-port (tt-conn
4d80: 2d 68 6f 73 74 2d 70 6f 72 74 20 63 6f 6e 6e 29 -host-port conn)
4d90: 29 20 3b 3b 20 28 63 6f 6e 63 20 28 74 74 2d 63 ) ;; (conc (tt-c
4da0: 6f 6e 6e 2d 68 6f 73 74 20 63 6f 6e 6e 29 22 3a onn-host conn)":
4db0: 22 28 74 74 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 "(tt-conn-port c
4dc0: 6f 6e 6e 29 29 29 0a 09 20 28 68 6f 73 74 20 20 onn))).. (host
4dd0: 20 20 20 20 28 74 74 2d 63 6f 6e 6e 2d 68 6f 73 (tt-conn-hos
4de0: 74 20 63 6f 6e 6e 29 29 0a 09 20 28 70 6f 72 74 t conn)).. (port
4df0: 20 20 20 20 20 20 28 74 74 2d 63 6f 6e 6e 2d 70 (tt-conn-p
4e00: 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 20 28 64 61 ort conn)).. (da
4e10: 74 20 20 20 20 20 20 20 28 6c 69 73 74 20 63 6d t (list cm
4e20: 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 d run-id params
4e30: 23 66 29 29 29 20 3b 3b 20 6e 6f 20 6d 65 74 61 #f))) ;; no meta
4e40: 20 64 61 74 61 20 79 65 74 0a 20 20 20 20 28 74 data yet. (t
4e50: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 64 t:send-receive-d
4e60: 69 72 65 63 74 20 68 6f 73 74 20 70 6f 72 74 20 irect host port
4e70: 64 61 74 29 29 29 0a 0a 28 64 65 66 73 74 72 75 dat)))..(defstru
4e80: 63 74 20 74 74 3a 62 61 63 6b 6f 66 66 0a 20 20 ct tt:backoff.
4e90: 28 6c 61 73 74 2d 69 6f 65 72 72 20 28 63 75 72 (last-ioerr (cur
4ea0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 rent-seconds)).
4eb0: 20 28 6c 61 73 74 2d 61 64 6a 2d 74 20 28 63 75 (last-adj-t (cu
4ec0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
4ed0: 20 20 28 77 61 69 74 2d 64 65 6c 61 79 20 30 2e (wait-delay 0.
4ee0: 31 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 74 74 1))..(define *tt
4ef0: 3a 62 61 63 6b 6f 66 66 2d 73 6d 6f 6f 74 68 69 :backoff-smoothi
4f00: 6e 67 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ng* (make-hash-t
4f10: 61 62 6c 65 29 29 20 3b 3b 20 68 6f 73 74 3a 70 able)) ;; host:p
4f20: 6f 72 74 20 3d 3e 20 6c 61 73 74 61 63 63 65 73 ort => lastacces
4f30: 73 20 62 61 63 6b 6f 66 66 64 65 6c 61 79 20 29 s backoffdelay )
4f40: 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 62 61 ..(define (tt:ba
4f50: 63 6b 6f 66 66 2d 69 6e 63 72 20 68 6f 73 74 20 ckoff-incr host
4f60: 70 6f 72 74 29 20 3b 3b 20 63 61 6c 6c 20 69 66 port) ;; call if
4f70: 20 74 63 70 20 66 61 69 6c 73 20 69 2f 6f 20 6e tcp fails i/o n
4f80: 65 74 0a 20 20 28 6c 65 74 2a 20 28 28 68 6f 73 et. (let* ((hos
4f90: 74 2d 70 6f 72 74 20 28 63 6f 6e 63 20 68 6f 73 t-port (conc hos
4fa0: 74 22 3a 22 70 6f 72 74 29 29 0a 09 20 28 62 6b t":"port)).. (bk
4fb0: 6f 66 66 20 20 20 20 20 28 68 61 73 68 2d 74 61 off (hash-ta
4fc0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4fd0: 2a 74 74 3a 62 61 63 6b 6f 66 66 2d 73 6d 6f 6f *tt:backoff-smoo
4fe0: 74 68 69 6e 67 2a 20 68 6f 73 74 2d 70 6f 72 74 thing* host-port
4ff0: 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 62 #f))). (if b
5000: 6b 6f 66 66 0a 09 28 62 65 67 69 6e 0a 09 20 20 koff..(begin..
5010: 28 74 74 3a 62 61 63 6b 6f 66 66 2d 6c 61 73 74 (tt:backoff-last
5020: 2d 69 6f 65 72 72 2d 73 65 74 21 20 62 6b 6f 66 -ioerr-set! bkof
5030: 66 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e f (current-secon
5040: 64 73 29 29 0a 09 20 20 28 74 74 3a 62 61 63 6b ds)).. (tt:back
5050: 6f 66 66 2d 77 61 69 74 2d 64 65 6c 61 79 2d 73 off-wait-delay-s
5060: 65 74 21 20 62 6b 6f 66 66 20 28 2b 20 28 74 74 et! bkoff (+ (tt
5070: 3a 62 61 63 6b 6f 66 66 2d 77 61 69 74 2d 64 65 :backoff-wait-de
5080: 6c 61 79 20 62 6b 6f 66 66 29 20 30 2e 31 29 29 lay bkoff) 0.1))
5090: 29 0a 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 )..(hash-table-s
50a0: 65 74 21 20 2a 74 74 3a 62 61 63 6b 6f 66 66 2d et! *tt:backoff-
50b0: 73 6d 6f 6f 74 68 69 6e 67 2a 20 68 6f 73 74 2d smoothing* host-
50c0: 70 6f 72 74 20 28 6d 61 6b 65 2d 74 74 3a 62 61 port (make-tt:ba
50d0: 63 6b 6f 66 66 29 29 29 29 29 0a 0a 28 64 65 66 ckoff)))))..(def
50e0: 69 6e 65 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d ine (tt:backoff-
50f0: 64 65 63 72 2d 61 6e 64 2d 77 61 69 74 20 68 6f decr-and-wait ho
5100: 73 74 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a st port). (let*
5110: 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 28 63 6f ((host-port (co
5120: 6e 63 20 68 6f 73 74 22 3a 22 70 6f 72 74 29 29 nc host":"port))
5130: 0a 09 20 28 62 6b 6f 66 66 20 20 20 20 20 28 68 .. (bkoff (h
5140: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5150: 66 61 75 6c 74 20 2a 74 74 3a 62 61 63 6b 6f 66 fault *tt:backof
5160: 66 2d 73 6d 6f 6f 74 68 69 6e 67 2a 20 68 6f 73 f-smoothing* hos
5170: 74 2d 70 6f 72 74 20 23 66 29 29 29 0a 20 20 20 t-port #f))).
5180: 20 28 69 66 20 62 6b 6f 66 66 0a 09 28 6c 65 74 (if bkoff..(let
5190: 2a 20 28 28 77 61 69 74 2d 64 65 6c 61 79 20 28 * ((wait-delay (
51a0: 74 74 3a 62 61 63 6b 6f 66 66 2d 77 61 69 74 2d tt:backoff-wait-
51b0: 64 65 6c 61 79 20 62 6b 6f 66 66 29 29 0a 09 20 delay bkoff))..
51c0: 20 20 20 20 20 20 28 6c 61 73 74 2d 69 6f 65 72 (last-ioer
51d0: 72 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d 6c 61 r (tt:backoff-la
51e0: 73 74 2d 69 6f 65 72 72 20 62 6b 6f 66 66 29 29 st-ioerr bkoff))
51f0: 0a 09 20 20 20 20 20 20 20 28 6c 61 73 74 2d 61 .. (last-a
5200: 64 6a 2d 74 20 28 74 74 3a 62 61 63 6b 6f 66 66 dj-t (tt:backoff
5210: 2d 6c 61 73 74 2d 61 64 6a 2d 74 20 62 6b 6f 66 -last-adj-t bkof
5220: 66 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 6c f)).. (del
5230: 74 61 20 20 20 20 20 20 28 2d 20 28 63 75 72 72 ta (- (curr
5240: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 ent-seconds) las
5250: 74 2d 61 64 6a 2d 74 29 29 0a 09 20 20 20 20 20 t-adj-t))..
5260: 20 20 28 61 64 6a 20 20 20 20 20 20 20 20 28 2a (adj (*
5270: 20 64 65 6c 74 61 20 30 2e 30 30 31 29 29 20 3b delta 0.001)) ;
5280: 3b 20 69 74 20 74 61 6b 65 73 20 31 30 30 20 73 ; it takes 100 s
5290: 65 63 6f 6e 64 73 20 74 6f 20 72 65 63 6f 76 65 econds to recove
52a0: 72 20 66 72 6f 6d 20 68 69 74 74 69 6e 67 20 61 r from hitting a
52b0: 6e 20 69 6f 20 65 72 72 0a 09 20 20 20 20 20 20 n io err..
52c0: 20 28 6e 65 77 2d 77 61 69 74 20 20 20 28 69 66 (new-wait (if
52d0: 20 28 3e 20 77 61 69 74 2d 64 65 6c 61 79 20 30 (> wait-delay 0
52e0: 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 ).... (if
52f0: 28 3e 20 61 64 6a 20 77 61 69 74 2d 64 65 6c 61 (> adj wait-dela
5300: 79 29 0a 09 09 09 09 20 20 20 30 0a 09 09 09 09 y)..... 0.....
5310: 20 20 20 28 2d 20 77 61 69 74 2d 64 65 6c 61 79 (- wait-delay
5320: 20 61 64 6a 29 29 0a 09 09 09 20 20 20 20 20 20 adj))....
5330: 20 30 29 29 29 0a 09 20 20 28 69 66 20 28 3e 20 0))).. (if (>
5340: 6e 65 77 2d 77 61 69 74 20 30 29 0a 09 20 20 20 new-wait 0)..
5350: 20 20 20 28 62 65 67 69 6e 0a 09 09 28 69 66 20 (begin...(if
5360: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
5370: 65 2d 70 72 69 6e 74 20 31 30 20 22 64 65 6c 61 e-print 10 "dela
5380: 79 20 77 61 69 74 20 6d 65 73 73 61 67 65 22 29 y wait message")
5390: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
53a0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
53b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
53c0: 65 72 76 65 72 20 6f 6e 20 68 6f 73 74 20 22 20 erver on host "
53d0: 68 6f 73 74 20 22 20 6c 6f 61 64 65 64 2c 20 44 host " loaded, D
53e0: 65 6c 61 79 57 61 69 74 3a 20 22 6e 65 77 2d 77 elayWait: "new-w
53f0: 61 69 74 29 29 0a 09 09 28 74 74 3a 62 61 63 6b ait))...(tt:back
5400: 6f 66 66 2d 77 61 69 74 2d 64 65 6c 61 79 2d 73 off-wait-delay-s
5410: 65 74 21 20 62 6b 6f 66 66 20 6e 65 77 2d 77 61 et! bkoff new-wa
5420: 69 74 29 0a 09 09 28 74 74 3a 62 61 63 6b 6f 66 it)...(tt:backof
5430: 66 2d 6c 61 73 74 2d 61 64 6a 2d 74 2d 73 65 74 f-last-adj-t-set
5440: 21 20 62 6b 6f 66 66 20 28 63 75 72 72 65 6e 74 ! bkoff (current
5450: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 28 74 68 -seconds))...(th
5460: 72 65 61 64 2d 73 6c 65 65 70 21 20 6e 65 77 2d read-sleep! new-
5470: 77 61 69 74 29 29 0a 09 20 20 20 20 20 20 28 68 wait)).. (h
5480: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
5490: 21 20 2a 74 74 3a 62 61 63 6b 6f 66 66 2d 73 6d ! *tt:backoff-sm
54a0: 6f 6f 74 68 69 6e 67 2a 20 68 6f 73 74 2d 70 6f oothing* host-po
54b0: 72 74 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e rt))))))..(defin
54c0: 65 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 e (tt:send-recei
54d0: 76 65 2d 64 69 72 65 63 74 20 68 6f 73 74 20 70 ve-direct host p
54e0: 6f 72 74 20 64 61 74 20 23 21 6b 65 79 20 28 70 ort dat #!key (p
54f0: 69 6e 67 2d 6d 6f 64 65 20 23 66 29 28 74 72 69 ing-mode #f)(tri
5500: 65 73 2d 72 65 6d 61 69 6e 69 6e 67 20 32 35 29 es-remaining 25)
5510: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d ). (assert (num
5520: 62 65 72 3f 20 70 6f 72 74 29 20 22 46 41 54 41 ber? port) "FATA
5530: 4c 3a 20 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 L: tt:send-recei
5540: 76 65 2d 64 69 72 65 63 74 20 63 61 6c 6c 65 64 ve-direct called
5550: 20 77 69 74 68 20 20 61 20 70 6f 72 74 20 74 68 with a port th
5560: 61 74 20 69 73 20 6e 6f 74 20 61 20 6e 75 6d 62 at is not a numb
5570: 65 72 20 22 70 6f 72 74 29 0a 20 20 28 74 74 3a er "port). (tt:
5580: 62 61 63 6b 6f 66 66 2d 64 65 63 72 2d 61 6e 64 backoff-decr-and
5590: 2d 77 61 69 74 20 68 6f 73 74 20 70 6f 72 74 29 -wait host port)
55a0: 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 74 72 79 . (let* ((retry
55b0: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
55c0: 61 20 28 29 0a 09 09 09 20 20 20 28 74 74 3a 73 a ().... (tt:s
55d0: 65 6e 64 2d 72 65 63 65 69 76 65 2d 64 69 72 65 end-receive-dire
55e0: 63 74 20 68 6f 73 74 20 70 6f 72 74 20 64 61 74 ct host port dat
55f0: 20 74 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e 67 tries-remaining
5600: 3a 20 28 2d 20 74 72 69 65 73 2d 72 65 6d 61 69 : (- tries-remai
5610: 6e 69 6e 67 20 31 29 29 29 29 0a 09 20 28 66 75 ning 1)))).. (fu
5620: 6c 6c 2d 65 72 72 2d 70 72 69 6e 74 20 28 6c 61 ll-err-print (la
5630: 6d 62 64 61 20 28 65 78 6e 20 6d 73 67 29 0a 09 mbda (exn msg)..
5640: 09 09 20 20 20 28 69 66 20 28 63 6f 6e 64 69 74 .. (if (condit
5650: 69 6f 6e 3f 20 65 78 6e 29 0a 09 09 09 20 20 20 ion? exn)....
5660: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 (begin.....
5670: 28 70 70 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e (pp (condition->
5680: 6c 69 73 74 20 65 78 6e 29 20 2a 64 65 66 61 75 list exn) *defau
5690: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 0a 09 09 lt-log-port*)...
56a0: 09 09 20 28 70 70 20 64 61 74 20 2a 64 65 66 61 .. (pp dat *defa
56b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 0a 09 ult-log-port*)..
56c0: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
56d0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
56e0: 70 6f 72 74 2a 20 6d 73 67 0a 09 09 09 09 09 20 port* msg......
56f0: 20 20 20 20 20 22 2c 20 65 72 72 6f 72 3a 20 22 ", error: "
5700: 20 20 20 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e ((condition
5710: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
5720: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
5730: 29 20 20 20 65 78 6e 29 0a 09 09 09 09 09 20 20 ) exn)......
5740: 20 20 20 20 22 2c 20 61 72 67 75 6d 65 6e 74 73 ", arguments
5750: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
5760: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
5770: 72 20 27 65 78 6e 20 27 61 72 67 75 6d 65 6e 74 r 'exn 'argument
5780: 73 29 20 65 78 6e 29 0a 09 09 09 09 09 20 20 20 s) exn)......
5790: 20 20 20 22 2c 20 6c 6f 63 61 74 69 6f 6e 3a 20 ", location:
57a0: 22 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
57b0: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
57c0: 20 27 65 78 6e 20 27 6c 6f 63 61 74 69 6f 6e 29 'exn 'location)
57d0: 20 20 65 78 6e 29 0a 09 09 09 09 09 20 20 20 20 exn)......
57e0: 20 20 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 )).... (
57f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
5800: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5810: 20 6d 73 67 20 22 28 6e 6f 74 65 3a 20 65 78 6e msg "(note: exn
5820: 3d 22 65 78 6e 22 2c 20 69 73 20 6e 6f 74 20 61 ="exn", is not a
5830: 20 63 6f 6e 64 69 74 69 6f 6e 20 6f 62 6a 65 63 condition objec
5840: 74 2e 22 29 29 29 29 29 0a 20 20 20 20 28 63 6f t."))))). (co
5850: 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a 20 20 20 ndition-case.
5860: 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 (let-values ((
5870: 28 69 6e 70 20 6f 75 70 29 28 74 63 70 2d 63 6f (inp oup)(tcp-co
5880: 6e 6e 65 63 74 20 68 6f 73 74 20 70 6f 72 74 29 nnect host port)
5890: 29 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 )). (let (
58a0: 28 72 65 73 20 28 69 66 20 28 61 6e 64 20 69 6e (res (if (and in
58b0: 70 20 6f 75 70 29 0a 09 09 20 20 20 20 20 20 28 p oup)... (
58c0: 62 65 67 69 6e 0a 09 09 09 28 73 65 72 69 61 6c begin....(serial
58d0: 69 7a 65 20 64 61 74 20 6f 75 70 29 0a 09 09 09 ize dat oup)....
58e0: 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
58f0: 72 74 20 6f 75 70 29 0a 09 09 09 28 64 65 73 65 rt oup)....(dese
5900: 72 69 61 6c 69 7a 65 20 69 6e 70 29 29 0a 09 09 rialize inp))...
5910: 20 20 20 20 20 20 29 29 29 0a 09 20 28 63 6c 6f ))).. (clo
5920: 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e se-input-port in
5930: 70 29 0a 09 20 28 6d 61 74 63 68 20 72 65 73 0a p).. (match res.
5940: 09 20 20 20 28 28 72 65 73 75 6c 74 20 65 78 6e . ((result exn
5950: 2d 72 65 73 75 6c 74 20 73 74 64 6f 75 74 2d 72 -result stdout-r
5960: 65 73 75 6c 74 29 0a 09 20 20 20 20 28 69 66 20 esult).. (if
5970: 65 78 6e 2d 72 65 73 75 6c 74 0a 09 09 28 66 75 exn-result...(fu
5980: 6c 6c 2d 65 72 72 2d 70 72 69 6e 74 20 65 78 6e ll-err-print exn
5990: 2d 72 65 73 75 6c 74 20 22 45 52 52 4f 52 3a 20 -result "ERROR:
59a0: 53 65 72 76 65 72 20 73 69 64 65 20 65 78 63 65 Server side exce
59b0: 70 74 69 6f 6e 20 64 65 74 65 63 74 65 64 22 29 ption detected")
59c0: 29 0a 09 20 20 20 20 28 69 66 20 73 74 64 6f 75 ).. (if stdou
59d0: 74 2d 72 65 73 75 6c 74 0a 09 09 28 64 65 62 75 t-result...(debu
59e0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
59f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
5a00: 52 4f 52 3a 20 4f 75 74 70 75 74 20 64 65 74 65 ROR: Output dete
5a10: 63 74 65 64 20 6f 6e 20 73 74 64 6f 75 74 20 6f cted on stdout o
5a20: 6e 20 73 65 72 76 65 72 20 73 69 64 65 20 65 78 n server side ex
5a30: 65 63 75 74 69 6f 6e 20 3d 3e 20 22 73 74 64 6f ecution => "stdo
5a40: 75 74 2d 72 65 73 75 6c 74 29 29 0a 09 20 20 20 ut-result))..
5a50: 20 72 65 73 75 6c 74 29 0a 09 20 20 20 28 65 6c result).. (el
5a60: 73 65 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 se.. (debug:p
5a70: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
5a80: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
5a90: 3a 20 73 65 72 76 65 72 20 72 65 74 75 72 6e 65 : server returne
5aa0: 64 20 6e 6f 6e 2d 73 74 61 6e 64 61 72 64 20 6f d non-standard o
5ab0: 75 74 70 75 74 3a 20 22 72 65 73 29 0a 09 20 20 utput: "res)..
5ac0: 20 20 23 66 29 29 29 29 0a 20 20 20 20 20 28 65 #f)))). (e
5ad0: 78 6e 20 28 69 6f 2d 65 72 72 6f 72 29 0a 09 20 xn (io-error)..
5ae0: 20 28 66 75 6c 6c 2d 65 72 72 2d 70 72 69 6e 74 (full-err-print
5af0: 20 65 78 6e 20 20 22 45 52 52 4f 52 3a 20 69 2f exn "ERROR: i/
5b00: 6f 20 65 72 72 6f 72 22 29 0a 09 20 20 28 74 74 o error").. (tt
5b10: 3a 62 61 63 6b 6f 66 66 2d 69 6e 63 72 20 68 6f :backoff-incr ho
5b20: 73 74 20 70 6f 72 74 29 0a 09 20 20 23 66 29 0a st port).. #f).
5b30: 20 20 20 20 20 28 65 78 6e 20 28 69 2f 6f 20 6e (exn (i/o n
5b40: 65 74 29 0a 09 20 20 28 69 66 20 70 69 6e 67 2d et).. (if ping-
5b50: 6d 6f 64 65 0a 09 20 20 20 20 20 20 23 66 0a 09 mode.. #f..
5b60: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 (cond..
5b70: 20 20 20 20 28 28 3e 20 20 74 72 69 65 73 2d 72 ((> tries-r
5b80: 65 6d 61 69 6e 69 6e 67 20 34 29 20 3b 3b 20 73 emaining 4) ;; s
5b90: 65 72 76 65 72 20 6c 69 6b 65 6c 79 20 64 65 66 erver likely def
5ba0: 75 6e 63 74 0a 09 09 28 74 74 3a 62 61 63 6b 6f unct...(tt:backo
5bb0: 66 66 2d 69 6e 63 72 20 68 6f 73 74 20 70 6f 72 ff-incr host por
5bc0: 74 29 0a 09 09 23 66 29 0a 09 20 20 20 20 20 20 t)...#f)..
5bd0: 20 28 28 3e 3d 20 74 72 69 65 73 2d 72 65 6d 61 ((>= tries-rema
5be0: 69 6e 69 6e 67 20 30 29 0a 09 09 28 6c 65 74 2a ining 0)...(let*
5bf0: 20 28 28 62 61 63 6b 6f 66 66 2d 64 65 6c 61 79 ((backoff-delay
5c00: 20 28 6d 61 78 20 28 2a 20 28 2d 20 32 36 20 74 (max (* (- 26 t
5c10: 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e 67 29 20 ries-remaining)
5c20: 30 2e 31 29 20 31 2e 30 29 29 29 0a 09 09 20 20 0.1) 1.0)))...
5c30: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
5c40: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5c50: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 54 43 50 20 * "WARNING: TCP
5c60: 6f 76 65 72 6c 6f 61 64 2c 20 74 72 79 69 6e 67 overload, trying
5c70: 20 61 67 61 69 6e 20 69 6e 20 22 62 61 63 6b 6f again in "backo
5c80: 66 66 2d 64 65 6c 61 79 22 73 2e 22 29 0a 09 09 ff-delay"s.")...
5c90: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
5ca0: 20 62 61 63 6b 6f 66 66 2d 64 65 6c 61 79 29 0a backoff-delay).
5cb0: 09 09 20 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d .. (tt:backoff-
5cc0: 69 6e 63 72 20 68 6f 73 74 20 70 6f 72 74 29 0a incr host port).
5cd0: 09 09 20 20 28 72 65 74 72 79 29 29 0a 09 09 3b .. (retry))...;
5ce0: 3b 20 28 61 73 73 65 72 74 20 23 66 20 22 46 41 ; (assert #f "FA
5cf0: 54 41 4c 3a 20 54 6f 6f 20 6d 61 6e 79 20 72 65 TAL: Too many re
5d00: 74 72 69 65 73 20 69 6e 20 74 74 3a 73 65 6e 64 tries in tt:send
5d10: 2d 72 65 63 65 69 76 65 2d 64 69 72 65 63 74 22 -receive-direct"
5d20: 29 0a 09 09 29 0a 09 20 20 20 20 20 20 20 28 65 )...).. (e
5d30: 6c 73 65 20 23 66 29 29 29 29 0a 20 20 20 20 20 lse #f)))).
5d40: 28 65 78 6e 20 28 29 0a 09 20 20 28 66 75 6c 6c (exn ().. (full
5d50: 2d 65 72 72 2d 70 72 69 6e 74 20 65 78 6e 20 22 -err-print exn "
5d60: 55 6e 68 61 6e 64 6c 65 64 20 65 78 63 65 70 74 Unhandled except
5d70: 69 6f 6e 20 66 72 6f 6d 20 63 6c 69 65 6e 74 20 ion from client
5d80: 73 69 64 65 2e 22 29 0a 09 20 20 23 66 29 29 29 side.").. #f)))
5d90: 29 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )...;;==========
5da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
5de0: 73 65 72 76 65 72 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d server.;;=======
5df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
5e30: 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 73 79 6e .(define (tt:syn
5e40: 63 2d 64 62 73 20 74 74 64 61 74 29 0a 20 20 23 c-dbs ttdat). #
5e50: 66 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 f)..(define *ser
5e60: 76 65 72 2d 73 74 61 72 74 2d 72 65 71 75 65 73 ver-start-reques
5e70: 74 73 2a 20 27 28 29 29 0a 0a 3b 3b 20 73 74 61 ts* '())..;; sta
5e80: 72 74 20 74 68 65 20 6c 69 73 74 65 6e 65 72 20 rt the listener
5e90: 61 6e 64 20 73 74 61 72 74 20 72 65 73 70 6f 6e and start respon
5ea0: 64 69 6e 67 20 74 6f 20 72 65 71 75 65 73 74 73 ding to requests
5eb0: 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 6f 72 67 .;;.;; NOTE: org
5ec0: 61 6e 69 73 65 20 62 79 20 64 62 66 6e 61 6d 65 anise by dbfname
5ed0: 2c 20 6e 6f 74 20 72 75 6e 2d 69 64 20 73 6f 20 , not run-id so
5ee0: 77 65 20 64 6f 6e 27 74 20 6e 65 65 64 0a 3b 3b we don't need.;;
5ef0: 20 20 20 20 20 20 20 74 6f 20 70 75 6c 6c 20 69 to pull i
5f00: 6e 20 6d 6f 72 65 20 6d 6f 64 75 6c 65 73 0a 3b n more modules.;
5f10: 3b 0a 3b 3b 20 54 68 69 73 20 69 73 20 74 68 65 ;.;; This is the
5f20: 20 72 6f 75 74 69 6e 65 20 63 61 6c 6c 65 64 20 routine called
5f30: 69 6e 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 20 in megatest.scm
5f40: 74 6f 20 73 74 61 72 74 20 61 20 73 65 72 76 65 to start a serve
5f50: 72 2e 20 4e 4f 54 45 3a 20 73 65 71 75 65 6e 63 r. NOTE: sequenc
5f60: 65 20 69 73 20 64 69 66 66 65 72 65 6e 74 20 66 e is different f
5f70: 6f 72 20 6d 61 69 6e 2e 64 62 20 76 73 2e 20 58 or main.db vs. X
5f80: 2e 64 62 0a 3b 3b 0a 3b 3b 20 53 65 72 76 65 72 .db.;;.;; Server
5f90: 20 76 69 61 62 69 6c 69 74 79 20 69 73 20 63 68 viability is ch
5fa0: 65 63 6b 65 64 20 69 6e 20 6b 65 65 70 2d 72 75 ecked in keep-ru
5fb0: 6e 6e 69 6e 67 2e 20 42 6c 69 6e 64 6c 79 20 73 nning. Blindly s
5fc0: 74 61 72 74 20 61 6e 64 20 72 75 6e 20 68 65 72 tart and run her
5fd0: 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 e..;;.(define (t
5fe0: 74 3a 73 74 61 72 74 2d 73 65 72 76 65 72 20 61 t:start-server a
5ff0: 72 65 61 70 61 74 68 20 72 75 6e 2d 69 64 20 64 reapath run-id d
6000: 62 66 6e 61 6d 65 2d 69 6e 20 68 61 6e 64 6c 65 bfname-in handle
6010: 72 20 6b 65 79 73 29 0a 20 20 28 61 73 73 65 72 r keys). (asser
6020: 74 20 61 72 65 61 70 61 74 68 20 22 46 41 54 41 t areapath "FATA
6030: 4c 3a 20 61 72 65 61 70 61 74 68 20 6e 6f 74 20 L: areapath not
6040: 70 72 6f 76 69 64 65 64 20 66 6f 72 20 74 74 3a provided for tt:
6050: 73 74 61 72 74 2d 73 65 72 76 65 72 22 29 0a 20 start-server").
6060: 20 28 6c 65 74 2a 20 28 28 74 74 64 61 74 20 20 (let* ((ttdat
6070: 20 28 6d 61 6b 65 2d 74 74 20 61 72 65 61 70 61 (make-tt areapa
6080: 74 68 3a 20 61 72 65 61 70 61 74 68 29 29 0a 09 th: areapath))..
6090: 20 28 64 62 66 6e 61 6d 65 20 28 6f 72 20 64 62 (dbfname (or db
60a0: 66 6e 61 6d 65 2d 69 6e 20 28 64 62 6d 6f 64 3a fname-in (dbmod:
60b0: 72 75 6e 2d 69 64 2d 3e 64 62 66 6e 61 6d 65 20 run-id->dbfname
60c0: 72 75 6e 2d 69 64 29 29 29 29 0a 20 20 20 20 28 run-id)))). (
60d0: 73 65 74 21 20 2a 73 65 72 76 65 72 2d 69 6e 66 set! *server-inf
60e0: 6f 2a 20 74 74 64 61 74 29 0a 20 20 20 20 28 6c o* ttdat). (l
60f0: 65 74 2a 20 28 28 64 62 73 74 72 75 63 74 20 20 et* ((dbstruct
6100: 20 28 64 62 6d 6f 64 3a 6f 70 65 6e 2d 64 62 6d (dbmod:open-dbm
6110: 6f 64 64 62 20 61 72 65 61 70 61 74 68 20 72 75 oddb areapath ru
6120: 6e 2d 69 64 20 64 62 66 6e 61 6d 65 20 28 64 62 n-id dbfname (db
6130: 66 69 6c 65 3a 64 62 2d 69 6e 69 74 2d 70 72 6f file:db-init-pro
6140: 63 29 20 6b 65 79 73 29 29 29 0a 20 20 20 20 20 c) keys))).
6150: 20 28 74 74 2d 68 61 6e 64 6c 65 72 2d 73 65 74 (tt-handler-set
6160: 21 20 74 74 64 61 74 20 28 68 61 6e 64 6c 65 72 ! ttdat (handler
6170: 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 20 20 dbstruct)).
6180: 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 69 6e (let* ((servin
6190: 66 2d 63 72 65 61 74 65 64 20 23 66 29 0a 09 20 f-created #f)..
61a0: 20 20 20 20 28 74 63 70 2d 74 68 72 65 61 64 20 (tcp-thread
61b0: 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 (make-threa
61c0: 64 0a 09 09 09 20 20 20 20 20 20 20 28 6c 61 6d d.... (lam
61d0: 62 64 61 20 28 29 0a 09 09 09 09 20 3b 3b 20 4e bda ()..... ;; N
61e0: 4f 54 45 3a 20 74 74 2d 70 6f 72 74 20 61 6e 64 OTE: tt-port and
61f0: 20 74 74 2d 68 6f 73 74 20 61 72 65 20 73 65 74 tt-host are set
6200: 20 69 6e 20 63 6f 6e 6e 65 63 74 2d 6c 69 73 74 in connect-list
6210: 65 6e 65 72 20 77 68 69 63 68 20 69 73 20 63 61 ener which is ca
6220: 6c 6c 65 64 20 75 6e 64 65 72 20 74 74 3a 73 74 lled under tt:st
6230: 61 72 74 2d 74 63 70 2d 73 65 72 76 65 72 0a 09 art-tcp-server..
6240: 09 09 09 20 28 74 74 3a 73 74 61 72 74 2d 74 63 ... (tt:start-tc
6250: 70 2d 73 65 72 76 65 72 20 74 74 64 61 74 29 29 p-server ttdat))
6260: 20 3b 3b 20 73 74 61 72 74 20 74 68 65 20 74 63 ;; start the tc
6270: 70 2d 73 65 72 76 65 72 20 77 68 69 63 68 20 61 p-server which a
6280: 70 70 6c 69 65 73 20 68 61 6e 64 6c 65 72 20 74 pplies handler t
6290: 6f 20 69 6e 63 6f 6d 69 6e 67 20 64 61 74 61 0a o incoming data.
62a0: 09 09 09 20 20 20 20 20 20 20 22 74 63 70 2d 73 ... "tcp-s
62b0: 65 72 76 65 72 2d 74 68 72 65 61 64 22 29 29 0a erver-thread")).
62c0: 09 20 20 20 20 20 28 72 75 6e 2d 74 68 72 65 61 . (run-threa
62d0: 64 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 d (make-thr
62e0: 65 61 64 0a 09 09 09 20 20 20 20 20 20 20 28 6c ead.... (l
62f0: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 28 74 ambda ()..... (t
6300: 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 74 t:keep-running t
6310: 74 64 61 74 20 64 62 66 6e 61 6d 65 20 64 62 73 tdat dbfname dbs
6320: 74 72 75 63 74 29 29 29 29 29 0a 09 28 74 68 72 truct)))))..(thr
6330: 65 61 64 2d 73 74 61 72 74 21 20 74 63 70 2d 74 ead-start! tcp-t
6340: 68 72 65 61 64 29 0a 0a 09 28 6c 65 74 2a 20 28 hread)...(let* (
6350: 28 61 72 65 61 70 61 74 68 20 20 20 20 20 28 74 (areapath (t
6360: 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 61 74 t-areapath ttdat
6370: 29 29 0a 09 20 20 20 20 20 20 20 28 6e 6f 73 79 )).. (nosy
6380: 6e 63 64 62 70 61 74 68 20 28 63 6f 6e 63 20 61 ncdbpath (conc a
6390: 72 65 61 70 61 74 68 22 2f 2e 6d 74 64 62 22 29 reapath"/.mtdb")
63a0: 29 0a 09 20 20 20 20 20 20 20 28 73 65 72 76 65 ).. (serve
63b0: 72 73 20 20 20 20 20 20 3b 3b 20 28 74 74 3a 66 rs ;; (tt:f
63c0: 69 6e 64 2d 73 65 72 76 65 72 20 61 72 65 61 70 ind-server areap
63d0: 61 74 68 20 64 62 66 6e 61 6d 65 29 29 29 0a 09 ath dbfname)))..
63e0: 09 28 74 74 3a 67 65 74 2d 73 65 72 76 65 72 2d .(tt:get-server-
63f0: 69 6e 66 6f 2d 73 6f 72 74 65 64 20 74 74 64 61 info-sorted ttda
6400: 74 20 64 62 66 6e 61 6d 65 29 29 20 3b 3b 20 28 t dbfname)) ;; (
6410: 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 73 host port starts
6420: 65 63 6f 6e 64 73 20 73 65 72 76 65 72 2d 69 64 econds server-id
6430: 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a 09 servinfofile)..
6440: 20 20 20 20 20 20 20 28 67 6f 6f 64 2d 73 72 76 (good-srv
6450: 72 73 20 20 0a 09 09 3b 3b 20 63 6f 6e 74 61 63 rs ...;; contac
6460: 74 20 73 65 72 76 65 72 73 20 76 69 61 20 70 69 t servers via pi
6470: 6e 67 2c 20 69 66 20 6e 6f 20 72 65 73 70 6f 6e ng, if no respon
6480: 73 65 20 72 65 6d 6f 76 65 20 74 68 65 20 2e 73 se remove the .s
6490: 65 72 76 69 6e 66 6f 20 66 69 6c 65 0a 09 09 28 ervinfo file...(
64a0: 6c 65 74 20 6c 6f 6f 70 20 28 28 73 65 72 76 72 let loop ((servr
64b0: 73 20 20 20 20 20 73 65 72 76 65 72 73 29 0a 09 s servers)..
64c0: 09 09 20 20 20 28 70 72 69 6d 65 2d 68 6f 73 74 .. (prime-host
64d0: 20 23 66 29 0a 09 09 09 20 20 20 28 72 65 73 75 #f).... (resu
64e0: 6c 74 20 20 20 20 27 28 29 29 29 0a 09 09 20 20 lt '()))...
64f0: 28 69 66 20 28 6e 75 6c 6c 3f 20 73 65 72 76 72 (if (null? servr
6500: 73 29 0a 09 09 20 20 20 20 20 20 28 72 65 76 65 s)... (reve
6510: 72 73 65 20 72 65 73 75 6c 74 29 0a 09 09 20 20 rse result)...
6520: 20 20 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 (let* ((serv
6530: 64 61 74 20 28 63 61 72 20 73 65 72 76 72 73 29 dat (car servrs)
6540: 29 29 0a 09 09 09 28 6d 61 74 63 68 20 73 65 72 ))....(match ser
6550: 76 64 61 74 0a 09 09 09 20 20 20 20 20 28 28 68 vdat.... ((h
6560: 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 73 65 ost port startse
6570: 63 6f 6e 64 73 20 73 65 72 76 65 72 2d 69 64 20 conds server-id
6580: 70 69 64 20 64 62 66 69 6c 65 6e 61 6d 65 20 73 pid dbfilename s
6590: 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a 20 20 20 ervinfofile).
65a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65b0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
65c0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
65d0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
65e0: 2a 20 22 47 6f 6f 64 20 73 65 72 76 69 6e 66 6f * "Good servinfo
65f0: 20 66 69 6c 65 3a 20 22 20 73 65 72 76 64 61 74 file: " servdat
6600: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 2a ).... (let*
6610: 20 28 28 70 69 6e 67 2d 72 65 73 20 20 28 74 74 ((ping-res (tt
6620: 3a 74 69 6d 65 64 2d 70 69 6e 67 20 68 6f 73 74 :timed-ping host
6630: 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 29 port server-id)
6640: 29 0a 09 09 09 09 20 20 20 20 20 28 67 6f 6f 64 )..... (good
6650: 2d 70 69 6e 67 20 28 6d 61 74 63 68 20 70 69 6e -ping (match pin
6660: 67 2d 72 65 73 0a 09 09 09 09 09 09 20 20 20 28 g-res....... (
6670: 28 72 65 73 75 6c 74 20 2e 20 70 69 6e 67 2d 74 (result . ping-t
6680: 69 6d 65 29 0a 09 09 09 09 09 09 20 20 20 20 28 ime)....... (
6690: 6e 6f 74 20 72 65 73 75 6c 74 29 29 20 3b 3b 20 not result)) ;;
66a0: 77 65 20 63 6f 75 6c 64 6e 27 74 20 72 65 61 63 we couldn't reac
66b0: 68 20 74 68 65 20 73 65 72 76 65 72 20 6f 72 20 h the server or
66c0: 69 74 20 77 61 73 20 6e 6f 74 20 61 20 6d 65 67 it was not a meg
66d0: 61 74 65 73 74 20 73 65 72 76 65 72 0a 09 09 09 atest server....
66e0: 09 09 09 20 20 20 28 65 6c 73 65 20 23 66 29 29 ... (else #f))
66f0: 29 20 3b 3b 20 74 68 65 20 70 69 6e 67 20 66 61 ) ;; the ping fa
6700: 69 6c 65 64 20 63 6f 6d 70 6c 65 74 65 6c 79 3f iled completely?
6710: 0a 09 09 09 09 20 20 20 20 20 28 73 61 6d 65 2d ..... (same-
6720: 68 6f 73 74 20 28 6f 72 20 28 6e 6f 74 20 70 72 host (or (not pr
6730: 69 6d 65 2d 68 6f 73 74 29 20 3b 3b 20 69 2e 65 ime-host) ;; i.e
6740: 2e 20 74 68 69 73 20 69 73 20 74 68 65 20 66 69 . this is the fi
6750: 72 73 74 20 68 6f 73 74 0a 09 09 09 09 09 09 20 rst host.......
6760: 20 20 20 28 65 71 75 61 6c 3f 20 70 72 69 6d 65 (equal? prime
6770: 2d 68 6f 73 74 20 68 6f 73 74 29 29 29 0a 09 09 -host host)))...
6780: 09 09 20 20 20 20 20 28 6b 65 65 70 2d 73 72 76 .. (keep-srv
6790: 20 20 28 61 6e 64 20 67 6f 6f 64 2d 70 69 6e 67 (and good-ping
67a0: 20 73 61 6d 65 2d 68 6f 73 74 29 29 29 0a 09 09 same-host)))...
67b0: 09 09 28 69 66 20 6b 65 65 70 2d 73 72 76 09 0a ..(if keep-srv..
67c0: 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 .... (loop (c
67d0: 64 72 20 73 65 72 76 72 73 29 0a 09 09 09 09 09 dr servrs)......
67e0: 20 20 68 6f 73 74 0a 09 09 09 09 09 20 20 28 63 host...... (c
67f0: 6f 6e 73 20 73 65 72 76 64 61 74 20 72 65 73 75 ons servdat resu
6800: 6c 74 29 29 0a 09 09 09 09 20 20 20 20 28 6c 65 lt))..... (le
6810: 74 2a 20 28 28 6d 6f 64 74 69 6d 65 20 28 66 69 t* ((modtime (fi
6820: 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d le-modification-
6830: 74 69 6d 65 20 73 65 72 76 69 6e 66 6f 66 69 6c time servinfofil
6840: 65 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 3b e)))..... ;
6850: 3b 20 69 66 20 74 68 65 20 2e 73 65 72 76 69 6e ; if the .servin
6860: 66 6f 20 68 61 73 6e 27 74 20 62 65 65 6e 20 74 fo hasn't been t
6870: 6f 75 63 68 65 64 20 69 6e 20 66 69 76 65 20 6d ouched in five m
6880: 69 6e 0a 09 09 09 09 20 20 20 20 20 20 3b 3b 20 in..... ;;
6890: 77 65 20 63 61 6e 20 62 65 20 70 72 65 74 74 79 we can be pretty
68a0: 20 73 75 72 65 20 74 68 65 20 73 65 72 76 65 72 sure the server
68b0: 20 69 73 20 74 72 75 6c 79 20 64 65 61 64 0a 09 is truly dead..
68c0: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ... (if (>
68d0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
68e0: 6e 64 73 29 20 6d 6f 64 74 69 6d 65 29 20 33 36 nds) modtime) 36
68f0: 30 29 0a 09 09 09 09 09 20 20 28 68 61 6e 64 6c 0)...... (handl
6900: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
6910: 09 09 20 20 20 65 78 6e 0a 09 09 09 09 09 20 20 .. exn......
6920: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
6930: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
6940: 67 2d 70 6f 72 74 2a 0a 09 09 09 09 09 09 09 20 g-port*........
6950: 20 20 20 20 22 45 72 72 6f 72 20 72 65 6d 6f 76 "Error remov
6960: 69 6e 67 20 73 65 72 76 65 72 20 69 6e 66 6f 20 ing server info
6970: 66 69 6c 65 3a 20 22 73 65 72 76 69 6e 66 6f 66 file: "servinfof
6980: 69 6c 65 22 2c 20 22 0a 09 09 09 09 09 09 09 20 ile", "........
6990: 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e (condition->
69a0: 6c 69 73 74 20 65 78 6e 29 29 0a 09 09 09 09 09 list exn))......
69b0: 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a (delete-file*
69c0: 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 29 0a servinfofile)).
69d0: 09 09 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 64 ..... (loop (cd
69e0: 72 20 73 65 72 76 72 73 29 20 70 72 69 6d 65 2d r servrs) prime-
69f0: 68 6f 73 74 20 72 65 73 75 6c 74 29 29 29 29 29 host result)))))
6a00: 29 0a 09 09 09 20 20 20 20 20 28 65 6c 73 65 0a ).... (else.
6a10: 09 09 09 20 20 20 20 20 20 3b 3b 20 63 61 6e 27 ... ;; can'
6a20: 74 20 64 65 6c 65 74 65 20 69 74 20 61 73 20 77 t delete it as w
6a30: 65 20 64 6f 6e 27 74 20 68 61 76 65 20 61 20 66 e don't have a f
6a40: 69 6c 65 6e 61 6d 65 2e 20 4e 4f 54 45 3a 20 53 ilename. NOTE: S
6a50: 68 6f 75 6c 64 20 6e 65 76 65 72 20 67 65 74 20 hould never get
6a60: 68 65 72 65 2e 0a 09 09 09 20 20 20 20 20 20 28 here..... (
6a70: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6a80: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6a90: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 62 61 port* "ERROR: ba
6aa0: 64 20 73 65 72 76 69 6e 66 6f 20 72 65 63 6f 72 d servinfo recor
6ab0: 64 20 5c 22 22 73 65 72 76 64 61 74 22 5c 22 22 d \""servdat"\""
6ac0: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ).... (loop
6ad0: 20 28 63 64 72 20 73 65 72 76 72 73 29 20 70 72 (cdr servrs) pr
6ae0: 69 6d 65 2d 68 6f 73 74 20 72 65 73 75 6c 74 29 ime-host result)
6af0: 29 20 3b 3b 20 64 72 6f 70 20 0a 09 09 09 20 20 ) ;; drop ....
6b00: 20 20 20 29 29 29 29 29 0a 09 20 20 20 20 20 20 )))))..
6b10: 20 28 68 6f 6d 65 2d 68 6f 73 74 20 28 69 66 20 (home-host (if
6b20: 28 6e 75 6c 6c 3f 20 67 6f 6f 64 2d 73 72 76 72 (null? good-srvr
6b30: 73 29 0a 09 09 09 20 20 20 20 20 20 23 66 0a 09 s).... #f..
6b40: 09 09 20 20 20 20 20 20 28 63 61 61 72 20 67 6f .. (caar go
6b50: 6f 64 2d 73 72 76 72 73 29 29 29 29 0a 09 20 20 od-srvrs))))..
6b60: 3b 3b 20 62 79 20 68 65 72 65 20 77 65 20 68 61 ;; by here we ha
6b70: 76 65 20 61 20 74 72 75 73 74 77 6f 72 74 68 79 ve a trustworthy
6b80: 20 6c 69 73 74 20 6f 66 20 73 65 72 76 65 72 73 list of servers
6b90: 20 61 6e 64 20 77 65 20 68 61 76 65 20 72 65 6d and we have rem
6ba0: 6f 76 65 64 20 74 68 65 20 2e 73 65 72 76 69 6e oved the .servin
6bb0: 66 6f 20 66 69 6c 65 20 66 6f 72 20 61 6e 79 20 fo file for any
6bc0: 75 6e 72 65 73 70 6f 6e 73 69 76 65 20 73 65 72 unresponsive ser
6bd0: 76 65 72 73 0a 09 20 20 3b 3b 20 61 6e 64 20 74 vers.. ;; and t
6be0: 68 65 20 6c 69 73 74 20 69 73 20 69 6e 20 67 6f he list is in go
6bf0: 6f 64 2d 73 72 76 72 73 0a 09 20 20 3b 3b 0a 09 od-srvrs.. ;;..
6c00: 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 6e 6f (cond.. ((no
6c10: 74 20 68 6f 6d 65 2d 68 6f 73 74 29 20 3b 3b 20 t home-host) ;;
6c20: 6e 6f 20 73 65 72 76 65 72 73 20 79 65 74 2c 20 no servers yet,
6c30: 67 6f 20 61 68 65 61 64 20 61 6e 64 20 73 74 61 go ahead and sta
6c40: 72 74 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 rt.. (debug:p
6c50: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
6c60: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6c70: 4e 6f 20 73 65 72 76 65 72 73 20 79 65 74 2c 20 No servers yet,
6c80: 73 74 61 72 74 69 6e 67 20 6f 6e 20 22 28 67 65 starting on "(ge
6c90: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 0a 09 t-host-name)))..
6ca0: 20 20 20 28 28 3e 20 28 6c 65 6e 67 74 68 20 67 ((> (length g
6cb0: 6f 6f 64 2d 73 72 76 72 73 29 20 33 29 20 3b 3b ood-srvrs) 3) ;;
6cc0: 20 64 6f 6e 27 74 20 6e 65 65 64 20 6d 6f 72 65 don't need more
6cd0: 2c 20 6a 75 73 74 20 65 78 69 74 0a 09 20 20 20 , just exit..
6ce0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
6cf0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
6d00: 67 2d 70 6f 72 74 2a 20 22 48 61 76 65 20 22 28 g-port* "Have "(
6d10: 6c 65 6e 67 74 68 20 67 6f 6f 64 2d 73 72 76 72 length good-srvr
6d20: 73 29 22 2c 20 6e 6f 20 6e 65 65 64 20 66 6f 72 s)", no need for
6d30: 20 6d 6f 72 65 2c 20 65 78 69 74 69 6e 67 2e 22 more, exiting."
6d40: 29 0a 09 20 20 20 20 28 65 78 69 74 29 29 0a 09 ).. (exit))..
6d50: 20 20 20 28 28 6e 6f 74 20 28 65 71 75 61 6c 3f ((not (equal?
6d60: 20 68 6f 6d 65 2d 68 6f 73 74 20 28 67 65 74 2d home-host (get-
6d70: 68 6f 73 74 2d 6e 61 6d 65 29 29 29 20 3b 3b 20 host-name))) ;;
6d80: 74 68 65 72 65 20 69 73 20 61 20 68 6f 6d 65 2d there is a home-
6d90: 68 6f 73 74 20 61 6e 64 20 77 65 20 61 72 65 20 host and we are
6da0: 6e 6f 74 20 6f 6e 20 69 74 0a 09 20 20 20 20 28 not on it.. (
6db0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6dc0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6dd0: 70 6f 72 74 2a 20 22 50 72 69 6d 65 20 6d 61 69 port* "Prime mai
6de0: 6e 20 73 65 72 76 65 72 20 69 73 20 6f 6e 20 68 n server is on h
6df0: 6f 73 74 20 22 68 6f 6d 65 2d 68 6f 73 74 22 2c ost "home-host",
6e00: 20 62 75 74 20 77 65 20 61 72 65 20 6f 6e 20 68 but we are on h
6e10: 6f 73 74 20 22 28 67 65 74 2d 68 6f 73 74 2d 6e ost "(get-host-n
6e20: 61 6d 65 29 22 2c 20 65 78 69 74 69 6e 67 2e 22 ame)", exiting."
6e30: 29 0a 09 20 20 20 20 28 65 78 69 74 29 29 0a 09 ).. (exit))..
6e40: 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 28 64 (else.. (d
6e50: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6e60: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
6e70: 6f 72 74 2a 20 22 53 74 61 72 74 69 6e 67 20 6f ort* "Starting o
6e80: 6e 20 68 6f 73 74 20 22 28 67 65 74 2d 68 6f 73 n host "(get-hos
6e90: 74 2d 6e 61 6d 65 29 22 2c 20 61 6c 6f 6e 67 20 t-name)", along
6ea0: 77 69 74 68 20 22 28 6c 65 6e 67 74 68 20 67 6f with "(length go
6eb0: 6f 64 2d 73 72 76 72 73 29 22 20 6f 74 68 65 72 od-srvrs)" other
6ec0: 20 73 65 72 76 65 72 73 2e 22 29 29 29 0a 0a 09 servers.")))...
6ed0: 20 20 3b 3b 20 74 68 69 73 20 64 69 64 6e 27 74 ;; this didn't
6ee0: 20 73 65 65 6d 20 74 6f 20 77 6f 72 6b 2c 20 69 seem to work, i
6ef0: 73 20 70 6f 72 74 20 6e 6f 74 20 61 76 61 69 6c s port not avail
6f00: 61 62 6c 65 20 79 65 74 3f 0a 09 20 20 28 6c 65 able yet?.. (le
6f10: 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 t loop ((count 0
6f20: 29 29 0a 09 20 20 20 20 28 69 66 20 28 74 74 2d )).. (if (tt-
6f30: 70 6f 72 74 20 74 74 64 61 74 29 0a 09 09 28 62 port ttdat)...(b
6f40: 65 67 69 6e 0a 09 09 20 20 28 70 72 6f 63 69 6e egin... (procin
6f50: 66 2d 70 6f 72 74 2d 73 65 74 21 20 2a 70 72 6f f-port-set! *pro
6f60: 63 69 6e 66 2a 20 28 74 74 2d 70 6f 72 74 20 74 cinf* (tt-port t
6f70: 74 64 61 74 29 29 0a 09 09 20 20 28 70 72 6f 63 tdat))... (proc
6f80: 69 6e 66 2d 64 62 6e 61 6d 65 2d 73 65 74 21 20 inf-dbname-set!
6f90: 2a 70 72 6f 63 69 6e 66 2a 20 64 62 66 6e 61 6d *procinf* dbfnam
6fa0: 65 29 0a 09 09 20 20 28 64 62 66 69 6c 65 3a 77 e)... (dbfile:w
6fb0: 69 74 68 2d 6e 6f 2d 73 79 6e 63 2d 64 62 0a 09 ith-no-sync-db..
6fc0: 09 20 20 20 6e 6f 73 79 6e 63 64 62 70 61 74 68 . nosyncdbpath
6fd0: 0a 09 09 20 20 20 28 6c 61 6d 62 64 61 20 28 6e ... (lambda (n
6fe0: 73 64 62 29 0a 09 09 20 20 20 20 20 28 64 62 66 sdb)... (dbf
6ff0: 69 6c 65 3a 69 6e 73 65 72 74 2d 6f 72 2d 75 70 ile:insert-or-up
7000: 64 61 74 65 2d 70 72 6f 63 65 73 73 20 6e 73 64 date-process nsd
7010: 62 20 2a 70 72 6f 63 69 6e 66 2a 29 29 29 29 0a b *procinf*)))).
7020: 09 09 28 69 66 20 28 3c 20 63 6f 75 6e 74 20 31 ..(if (< count 1
7030: 30 29 0a 09 09 20 20 20 20 28 62 65 67 69 6e 0a 0)... (begin.
7040: 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
7050: 73 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 09 20 sleep! 0.25)...
7060: 20 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f (loop (+ co
7070: 75 6e 74 20 31 29 29 29 0a 09 09 20 20 20 20 28 unt 1)))... (
7080: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 begin... (d
7090: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
70a0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
70b0: 22 45 52 52 4f 52 3a 20 28 74 74 2d 70 6f 72 74 "ERROR: (tt-port
70c0: 20 74 74 64 61 74 29 20 6e 6f 20 70 6f 72 74 20 ttdat) no port
70d0: 73 65 74 21 20 45 78 69 74 69 6e 67 2e 22 29 0a set! Exiting.").
70e0: 09 09 20 20 20 20 20 20 28 65 78 69 74 29 29 29 .. (exit)))
70f0: 29 29 0a 09 20 20 0a 09 20 20 3b 3b 20 63 72 65 )).. .. ;; cre
7100: 61 74 65 20 61 20 73 65 72 76 69 6e 66 6f 20 66 ate a servinfo f
7110: 69 6c 65 20 73 74 61 72 74 20 6b 65 65 70 2d 72 ile start keep-r
7120: 75 6e 6e 69 6e 67 0a 09 20 20 3b 3b 20 4f 6e 20 unning.. ;; On
7130: 57 53 4c 20 74 68 65 72 65 20 73 65 65 6d 73 20 WSL there seems
7140: 74 6f 20 62 65 20 61 20 72 61 63 65 20 63 6f 6e to be a race con
7150: 64 69 74 69 6f 6e 20 77 68 65 72 65 20 74 68 65 dition where the
7160: 20 2e 73 65 72 76 69 6e 66 6f 20 66 69 6c 65 0a .servinfo file.
7170: 09 20 20 3b 3b 20 69 73 20 6e 6f 74 20 63 72 65 . ;; is not cre
7180: 61 74 65 64 20 66 61 73 74 20 65 6e 6f 75 67 68 ated fast enough
7190: 0a 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 . (debu
71a0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
71b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 72 lt-log-port* "Cr
71c0: 65 61 74 69 6e 67 20 73 65 72 76 69 6e 66 6f 20 eating servinfo
71d0: 66 69 6c 65 20 66 6f 72 20 22 20 64 62 66 6e 61 file for " dbfna
71e0: 6d 65 29 0a 09 20 20 28 74 74 3a 63 72 65 61 74 me).. (tt:creat
71f0: 65 2d 73 65 72 76 65 72 2d 72 65 67 69 73 74 72 e-server-registr
7200: 61 74 69 6f 6e 2d 66 69 6c 65 20 74 74 64 61 74 ation-file ttdat
7210: 20 64 62 66 6e 61 6d 65 29 0a 09 20 20 28 70 72 dbfname).. (pr
7220: 6f 63 69 6e 66 2d 73 74 61 74 75 73 2d 73 65 74 ocinf-status-set
7230: 21 20 2a 70 72 6f 63 69 6e 66 2a 20 22 72 75 6e ! *procinf* "run
7240: 6e 69 6e 67 22 29 0a 09 20 20 28 74 74 2d 73 74 ning").. (tt-st
7250: 61 74 65 2d 73 65 74 21 20 74 74 64 61 74 20 27 ate-set! ttdat '
7260: 72 75 6e 6e 69 6e 67 29 0a 09 20 20 28 64 62 66 running).. (dbf
7270: 69 6c 65 3a 77 69 74 68 2d 6e 6f 2d 73 79 6e 63 ile:with-no-sync
7280: 2d 64 62 0a 09 20 20 20 6e 6f 73 79 6e 63 64 62 -db.. nosyncdb
7290: 70 61 74 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 path.. (lambda
72a0: 20 28 6e 73 64 62 29 0a 09 20 20 20 20 20 28 64 (nsdb).. (d
72b0: 62 66 69 6c 65 3a 69 6e 73 65 72 74 2d 6f 72 2d bfile:insert-or-
72c0: 75 70 64 61 74 65 2d 70 72 6f 63 65 73 73 20 6e update-process n
72d0: 73 64 62 20 2a 70 72 6f 63 69 6e 66 2a 29 29 29 sdb *procinf*)))
72e0: 0a 09 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 .. (thread-star
72f0: 74 21 20 72 75 6e 2d 74 68 72 65 61 64 29 0a 0a t! run-thread)..
7300: 09 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 . (thread-join!
7310: 20 72 75 6e 2d 74 68 72 65 61 64 29 20 3b 3b 20 run-thread) ;;
7320: 72 75 6e 20 74 68 72 65 61 64 20 77 69 6c 6c 20 run thread will
7330: 65 78 69 74 20 6f 6e 20 74 69 6d 65 6f 75 74 20 exit on timeout
7340: 6f 72 20 6f 74 68 65 72 20 63 6f 6e 64 69 74 69 or other conditi
7350: 6f 6e 73 0a 09 20 20 0a 09 20 20 3b 3b 20 28 74 ons.. .. ;; (t
7360: 63 70 2d 63 6c 6f 73 65 20 28 74 74 2d 73 6f 63 cp-close (tt-soc
7370: 6b 65 74 20 74 74 64 61 74 29 29 20 3b 3b 20 63 ket ttdat)) ;; c
7380: 6c 6f 73 65 20 75 70 20 70 6f 72 74 73 20 68 65 lose up ports he
7390: 72 65 0a 0a 09 20 20 3b 3b 20 72 65 70 6c 61 63 re... ;; replac
73a0: 65 20 77 69 74 68 20 63 61 6c 6c 20 74 6f 20 28 e with call to (
73b0: 64 62 66 69 6c 65 3a 73 65 74 2d 70 72 6f 63 65 dbfile:set-proce
73c0: 73 73 2d 64 6f 6e 65 20 6e 73 64 62 20 68 6f 73 ss-done nsdb hos
73d0: 74 20 70 69 64 20 72 65 61 73 6f 6e 29 0a 09 20 t pid reason)..
73e0: 20 28 70 72 6f 63 69 6e 66 2d 73 74 61 74 75 73 (procinf-status
73f0: 2d 73 65 74 21 20 2a 70 72 6f 63 69 6e 66 2a 20 -set! *procinf*
7400: 22 64 6f 6e 65 22 29 0a 09 20 20 28 70 72 6f 63 "done").. (proc
7410: 69 6e 66 2d 65 6e 64 2d 73 65 74 21 20 2a 70 72 inf-end-set! *pr
7420: 6f 63 69 6e 66 2a 20 28 63 75 72 72 65 6e 74 2d ocinf* (current-
7430: 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 3b 3b 20 seconds)).. ;;
7440: 65 69 74 68 65 72 20 63 6f 6e 76 65 72 74 20 74 either convert t
7450: 68 69 73 20 74 6f 20 75 73 65 20 73 65 74 2d 70 his to use set-p
7460: 72 6f 63 65 73 73 2d 64 6f 6e 65 20 6f 72 20 67 rocess-done or g
7470: 65 74 20 72 69 64 20 6f 66 20 73 65 74 2d 70 72 et rid of set-pr
7480: 6f 63 65 73 73 2d 64 6f 6e 65 0a 09 20 20 28 64 ocess-done.. (d
7490: 62 66 69 6c 65 3a 77 69 74 68 2d 6e 6f 2d 73 79 bfile:with-no-sy
74a0: 6e 63 2d 64 62 0a 09 20 20 20 6e 6f 73 79 6e 63 nc-db.. nosync
74b0: 64 62 70 61 74 68 0a 09 20 20 20 28 6c 61 6d 62 dbpath.. (lamb
74c0: 64 61 20 28 6e 73 64 62 29 0a 09 20 20 20 20 20 da (nsdb)..
74d0: 28 64 62 66 69 6c 65 3a 69 6e 73 65 72 74 2d 6f (dbfile:insert-o
74e0: 72 2d 75 70 64 61 74 65 2d 70 72 6f 63 65 73 73 r-update-process
74f0: 20 6e 73 64 62 20 2a 70 72 6f 63 69 6e 66 2a 29 nsdb *procinf*)
7500: 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 )).. (debug:pri
7510: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
7520: 67 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 g-port* "Exiting
7530: 20 6e 6f 77 2e 22 29 0a 09 20 20 28 65 78 69 74 now.").. (exit
7540: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
7550: 28 74 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 (tt:keep-running
7560: 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 20 64 ttdat dbfname d
7570: 62 73 74 72 75 63 74 29 0a 0a 20 20 28 74 68 72 bstruct).. (thr
7580: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 20 20 ead-sleep! 1).
7590: 0a 20 20 3b 3b 20 61 74 20 74 68 69 73 20 70 6f . ;; at this po
75a0: 69 6e 74 20 74 68 65 20 73 65 72 76 65 72 20 69 int the server i
75b0: 73 20 72 75 6e 6e 69 6e 67 20 61 6e 64 20 72 65 s running and re
75c0: 73 70 6f 6e 64 69 6e 67 20 74 6f 20 63 61 6c 6c sponding to call
75d0: 73 2c 20 77 65 20 6a 75 73 74 20 6d 6f 6e 69 74 s, we just monit
75e0: 6f 72 0a 20 20 3b 3b 20 66 6f 72 20 64 62 20 63 or. ;; for db c
75f0: 61 6c 6c 73 20 61 6e 64 20 65 78 69 74 20 69 66 alls and exit if
7600: 20 74 68 65 72 65 20 61 72 65 20 6e 6f 6e 65 2e there are none.
7610: 0a 0a 20 20 3b 3b 20 69 66 20 49 20 61 6d 20 6e .. ;; if I am n
7620: 6f 74 20 69 6e 20 74 68 65 20 66 69 72 73 74 20 ot in the first
7630: 33 20 73 65 72 76 65 72 73 2c 20 65 78 69 74 0a 3 servers, exit.
7640: 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 2d (let* ((start-
7650: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 time (current-se
7660: 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 6c 65 conds))). (le
7670: 74 20 6c 6f 6f 70 20 28 29 0a 20 20 20 20 20 20 t loop ().
7680: 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 73 20 (let* ((servers
7690: 20 20 28 74 74 3a 67 65 74 2d 73 65 72 76 65 72 (tt:get-server
76a0: 2d 69 6e 66 6f 2d 73 6f 72 74 65 64 20 74 74 64 -info-sorted ttd
76b0: 61 74 20 64 62 66 6e 61 6d 65 29 29 0a 09 20 20 at dbfname))..
76c0: 20 20 20 28 68 6f 6d 65 2d 68 6f 73 74 20 28 69 (home-host (i
76d0: 66 20 28 6e 75 6c 6c 3f 20 73 65 72 76 65 72 73 f (null? servers
76e0: 29 0a 09 09 09 20 20 20 20 23 66 0a 09 09 09 20 ).... #f....
76f0: 20 20 20 28 63 61 61 72 20 73 65 72 76 65 72 73 (caar servers
7700: 29 29 29 0a 09 20 20 20 20 20 28 6d 79 2d 69 6e ))).. (my-in
7710: 64 65 78 20 20 28 6c 69 73 74 2d 69 6e 64 65 78 dex (list-index
7720: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 (lambda (x)....
7730: 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 . (equal? (
7740: 6c 69 73 74 2d 72 65 66 20 78 20 36 29 0a 09 09 list-ref x 6)...
7750: 09 09 09 20 20 20 20 20 20 28 74 74 2d 73 65 72 ... (tt-ser
7760: 76 69 6e 66 2d 66 69 6c 65 20 74 74 64 61 74 29 vinf-file ttdat)
7770: 29 29 0a 09 09 09 09 20 20 20 20 73 65 72 76 65 ))..... serve
7780: 72 73 29 29 0a 09 20 20 20 20 20 28 6f 6b 20 20 rs)).. (ok
7790: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 (cond....
77a0: 20 20 28 28 6e 6f 74 20 6d 79 2d 69 6e 64 65 78 ((not my-index
77b0: 29 0a 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 ).... (debug:p
77c0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
77d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
77e0: 4e 47 3a 20 41 70 70 61 72 65 6e 74 6c 79 20 49 NG: Apparently I
77f0: 20 64 6f 6e 27 74 20 65 78 69 73 74 2e 22 29 0a don't exist.").
7800: 09 09 09 20 20 20 23 66 29 20 3b 3b 20 6b 65 65 ... #f) ;; kee
7810: 70 20 74 72 79 69 6e 67 20 6f 72 20 67 69 76 65 p trying or give
7820: 20 75 70 3f 0a 09 09 09 20 20 28 28 6e 6f 74 20 up?.... ((not
7830: 2a 73 65 72 76 65 72 2d 72 75 6e 2a 29 0a 09 09 *server-run*)...
7840: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
7850: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
7860: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
7870: 72 65 63 65 69 76 65 64 20 61 20 73 74 6f 70 20 received a stop
7880: 73 65 72 76 65 72 20 66 72 6f 6d 20 63 6c 69 65 server from clie
7890: 6e 74 20 62 79 20 72 65 6d 6f 74 65 20 72 65 71 nt by remote req
78a0: 75 65 73 74 2e 22 29 0a 09 09 09 20 20 20 23 66 uest.").... #f
78b0: 29 0a 09 09 09 20 20 28 28 6e 75 6c 6c 3f 20 73 ).... ((null? s
78c0: 65 72 76 65 72 73 29 0a 09 09 09 20 20 20 28 64 ervers).... (d
78d0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
78e0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
78f0: 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 73 65 72 "WARNING: no ser
7900: 76 69 6e 66 6f 20 66 69 6c 65 73 20 66 6f 75 6e vinfo files foun
7910: 64 2c 20 74 68 69 73 20 63 61 6e 6e 6f 74 20 62 d, this cannot b
7920: 65 2e 22 29 0a 09 09 09 20 20 20 23 66 29 20 3b e.").... #f) ;
7930: 3b 20 6e 6f 74 20 6f 6b 0a 09 09 09 20 20 28 28 ; not ok.... ((
7940: 3e 20 6d 79 2d 69 6e 64 65 78 20 33 29 0a 09 09 > my-index 3)...
7950: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
7960: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
7970: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
7980: 74 68 65 72 65 20 61 72 65 20 6d 6f 72 65 20 74 there are more t
7990: 68 61 6e 20 74 68 72 65 65 20 73 65 72 76 65 72 han three server
79a0: 73 20 61 68 65 61 64 20 6f 66 20 6d 65 2c 20 49 s ahead of me, I
79b0: 27 6d 20 6e 6f 74 20 6e 65 65 64 65 64 2c 20 65 'm not needed, e
79c0: 78 69 74 69 6e 67 2e 22 29 0a 09 09 09 20 20 20 xiting.")....
79d0: 23 66 29 20 3b 3b 20 6e 6f 74 20 6f 6b 20 74 6f #f) ;; not ok to
79e0: 20 6e 6f 74 20 62 65 20 69 6e 20 66 69 72 73 74 not be in first
79f0: 20 74 68 72 65 65 0a 09 09 09 20 20 28 28 65 71 three.... ((eq
7a00: 3f 20 28 74 74 2d 73 74 61 74 65 20 74 74 64 61 ? (tt-state ttda
7a10: 74 29 20 27 72 75 6e 6e 69 6e 67 29 20 23 74 29 t) 'running) #t)
7a20: 20 3b 3b 20 77 65 20 61 72 65 20 67 6f 6f 64 20 ;; we are good
7a30: 74 6f 20 6b 65 65 70 20 67 6f 69 6e 67 0a 09 09 to keep going...
7a40: 09 20 20 28 28 3e 20 28 2d 20 28 63 75 72 72 65 . ((> (- (curre
7a50: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 72 nt-seconds) star
7a60: 74 2d 74 69 6d 65 29 20 33 30 29 0a 09 09 09 20 t-time) 30)....
7a70: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
7a80: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
7a90: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6f 76 rt* "WARNING: ov
7aa0: 65 72 20 33 30 20 73 65 63 6f 6e 64 73 20 61 6e er 30 seconds an
7ab0: 64 20 6e 6f 74 20 79 65 74 20 69 6e 20 72 75 6e d not yet in run
7ac0: 6e 6e 69 6e 67 20 6d 6f 64 65 2e 20 45 78 69 74 nning mode. Exit
7ad0: 69 6e 67 2e 22 29 0a 09 09 09 20 20 20 23 66 29 ing.").... #f)
7ae0: 0a 09 09 09 20 20 28 65 6c 73 65 20 23 74 29 29 .... (else #t))
7af0: 29 29 0a 09 28 69 66 20 6f 6b 0a 09 20 20 20 20 ))..(if ok..
7b00: 28 74 74 2d 6c 61 73 74 2d 61 63 63 65 73 73 2d (tt-last-access-
7b10: 73 65 74 21 20 74 74 64 61 74 20 2a 64 62 2d 6c set! ttdat *db-l
7b20: 61 73 74 2d 61 63 63 65 73 73 2a 29 20 3b 3b 20 ast-access*) ;;
7b30: 62 69 74 20 73 69 6c 6c 79 2c 20 6a 75 73 74 20 bit silly, just
7b40: 75 73 65 20 64 62 2d 6c 61 73 74 2d 61 63 63 65 use db-last-acce
7b50: 73 73 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 ss.. (begin..
7b60: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7b70: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
7b80: 67 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 g-port* "Exiting
7b90: 20 69 6d 6d 65 64 69 61 74 65 6c 79 22 29 0a 09 immediately")..
7ba0: 20 20 20 20 20 20 28 74 74 3a 73 68 75 74 64 6f (tt:shutdo
7bb0: 77 6e 2d 73 65 72 76 65 72 20 74 74 64 61 74 29 wn-server ttdat)
7bc0: 0a 09 20 20 20 20 20 20 28 65 78 69 74 29 29 29 .. (exit)))
7bd0: 0a 0a 09 28 6c 65 74 2a 20 28 28 6c 61 73 74 2d ...(let* ((last-
7be0: 75 70 64 61 74 65 20 28 64 62 72 3a 64 62 73 74 update (dbr:dbst
7bf0: 72 75 63 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 ruct-last-update
7c00: 20 64 62 73 74 72 75 63 74 29 29 0a 09 20 20 20 dbstruct))..
7c10: 20 20 20 20 28 63 75 72 72 2d 73 65 63 73 20 20 (curr-secs
7c20: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
7c30: 73 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 s))).. (if (and
7c40: 20 28 65 71 3f 20 28 74 74 2d 73 74 61 74 65 20 (eq? (tt-state
7c50: 74 74 64 61 74 29 20 27 72 75 6e 6e 69 6e 67 29 ttdat) 'running)
7c60: 0a 09 09 20 20 20 28 3e 20 28 2d 20 63 75 72 72 ... (> (- curr
7c70: 2d 73 65 63 73 20 6c 61 73 74 2d 75 70 64 61 74 -secs last-updat
7c80: 65 29 20 35 29 29 20 3b 3b 20 65 76 65 72 79 20 e) 5)) ;; every
7c90: 35 20 73 65 63 6f 6e 64 73 20 75 70 64 61 74 65 5 seconds update
7ca0: 20 74 68 65 20 64 62 3f 0a 09 20 20 20 20 20 20 the db?..
7cb0: 28 6c 65 74 2a 20 28 28 73 69 6e 66 6f 2d 66 69 (let* ((sinfo-fi
7cc0: 6c 65 20 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 le (tt-servinf-f
7cd0: 69 6c 65 20 74 74 64 61 74 29 29 29 0a 09 09 3b ile ttdat)))...;
7ce0: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
7cf0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
7d00: 72 74 2a 20 22 49 4e 46 4f 3a 20 74 6f 75 63 68 rt* "INFO: touch
7d10: 69 6e 67 20 22 73 69 6e 66 6f 2d 66 69 6c 65 29 ing "sinfo-file)
7d20: 0a 09 09 28 73 65 74 21 20 28 66 69 6c 65 2d 6d ...(set! (file-m
7d30: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
7d40: 20 73 69 6e 66 6f 2d 66 69 6c 65 29 20 28 63 75 sinfo-file) (cu
7d50: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
7d60: 09 09 28 28 64 62 72 3a 64 62 73 74 72 75 63 74 ..((dbr:dbstruct
7d70: 2d 73 79 6e 63 2d 70 72 6f 63 20 64 62 73 74 72 -sync-proc dbstr
7d80: 75 63 74 29 20 6c 61 73 74 2d 75 70 64 61 74 65 uct) last-update
7d90: 29 0a 09 09 28 64 62 72 3a 64 62 73 74 72 75 63 )...(dbr:dbstruc
7da0: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 65 t-last-update-se
7db0: 74 21 20 64 62 73 74 72 75 63 74 20 63 75 72 72 t! dbstruct curr
7dc0: 2d 73 65 63 73 29 29 29 29 0a 09 0a 09 28 69 66 -secs))))....(if
7dd0: 20 28 3c 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (< (- (current-
7de0: 73 65 63 6f 6e 64 73 29 20 28 74 74 2d 6c 61 73 seconds) (tt-las
7df0: 74 2d 61 63 63 65 73 73 20 74 74 64 61 74 29 29 t-access ttdat))
7e00: 20 28 74 74 2d 73 65 72 76 65 72 2d 74 69 6d 65 (tt-server-time
7e10: 6f 75 74 2d 70 61 72 61 6d 29 29 0a 09 20 20 20 out-param))..
7e20: 20 3b 3b 20 70 72 6f 63 65 73 73 20 61 6e 79 20 ;; process any
7e30: 72 65 71 75 65 73 74 73 20 74 6f 20 73 74 61 72 requests to star
7e40: 74 20 61 20 6e 65 77 20 73 65 72 76 65 72 20 64 t a new server d
7e50: 75 65 20 74 6f 20 6c 6f 61 64 20 6f 6e 20 74 68 ue to load on th
7e60: 69 73 20 6f 6e 65 0a 09 20 20 20 20 28 6c 65 74 is one.. (let
7e70: 2a 20 28 28 72 65 71 75 65 73 74 73 20 2a 73 65 * ((requests *se
7e80: 72 76 65 72 2d 73 74 61 72 74 2d 72 65 71 75 65 rver-start-reque
7e90: 73 74 73 2a 29 29 0a 09 20 20 20 20 20 20 28 73 sts*)).. (s
7ea0: 65 74 21 20 2a 73 65 72 76 65 72 2d 73 74 61 72 et! *server-star
7eb0: 74 2d 72 65 71 75 65 73 74 73 2a 20 27 28 29 29 t-requests* '())
7ec0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 .. (if (> (
7ed0: 6c 65 6e 67 74 68 20 72 65 71 75 65 73 74 73 29 length requests)
7ee0: 20 30 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 0)... (debug:p
7ef0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
7f00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7f10: 50 72 6f 63 65 73 73 69 6e 67 20 22 28 6c 65 6e Processing "(len
7f20: 67 74 68 20 72 65 71 75 65 73 74 73 29 22 20 73 gth requests)" s
7f30: 65 72 76 65 72 20 73 74 61 72 74 20 72 65 71 75 erver start requ
7f40: 65 73 74 73 22 29 29 0a 09 20 20 20 20 20 20 28 ests")).. (
7f50: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
7f60: 20 28 70 72 6f 63 29 0a 09 09 09 20 20 28 70 72 (proc).... (pr
7f70: 6f 63 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 oc).... (thread
7f80: 2d 73 6c 65 65 70 21 20 31 29 29 0a 09 09 09 72 -sleep! 1))....r
7f90: 65 71 75 65 73 74 73 29 0a 09 20 20 20 20 20 20 equests)..
7fa0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 (thread-sleep! 5
7fb0: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 29 29 ).. (loop))
7fc0: 29 29 29 0a 20 20 20 20 28 74 74 3a 73 68 75 74 ))). (tt:shut
7fd0: 64 6f 77 6e 2d 73 65 72 76 65 72 20 74 74 64 61 down-server ttda
7fe0: 74 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 t). (debug:pr
7ff0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
8000: 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 og-port* "INFO:
8010: 53 65 72 76 65 72 20 74 69 6d 65 64 20 6f 75 74 Server timed out
8020: 2c 20 65 78 69 74 69 6e 67 20 66 72 6f 6d 20 74 , exiting from t
8030: 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 2e 22 t:keep-running."
8040: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 )))...(define (t
8050: 74 3a 73 68 75 74 64 6f 77 6e 2d 73 65 72 76 65 t:shutdown-serve
8060: 72 20 74 74 64 61 74 29 0a 20 20 28 6c 65 74 2a r ttdat). (let*
8070: 20 28 28 68 6f 73 74 20 28 74 74 2d 68 6f 73 74 ((host (tt-host
8080: 20 74 74 64 61 74 29 29 0a 09 20 28 70 6f 72 74 ttdat)).. (port
8090: 20 28 74 74 2d 70 6f 72 74 20 74 74 64 61 74 29 (tt-port ttdat)
80a0: 29 0a 09 20 28 73 69 6e 66 20 28 74 74 2d 73 65 ).. (sinf (tt-se
80b0: 72 76 69 6e 66 2d 66 69 6c 65 20 74 74 64 61 74 rvinf-file ttdat
80c0: 29 29 29 0a 20 20 20 20 28 74 74 2d 73 74 61 74 ))). (tt-stat
80d0: 65 2d 73 65 74 21 20 74 74 64 61 74 20 27 73 68 e-set! ttdat 'sh
80e0: 75 74 64 6f 77 6e 29 0a 20 20 20 20 28 70 6f 72 utdown). (por
80f0: 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e tlogger:open-run
8100: 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 -close portlogge
8110: 72 3a 73 65 74 2d 70 6f 72 74 20 70 6f 72 74 20 r:set-port port
8120: 22 72 65 6c 65 61 73 65 64 22 29 0a 20 20 20 20 "released").
8130: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
8140: 3f 20 73 69 6e 66 29 0a 09 28 64 65 6c 65 74 65 ? sinf)..(delete
8150: 2d 66 69 6c 65 2a 20 73 69 6e 66 29 29 0a 20 20 -file* sinf)).
8160: 20 20 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 ))..;; return
8170: 73 65 72 76 69 64 0a 3b 3b 20 73 69 64 65 2d 65 servid.;; side-e
8180: 66 66 65 63 74 73 3a 0a 3b 3b 20 20 20 74 74 64 ffects:.;; ttd
8190: 61 74 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 at-cleanup-proc
81a0: 69 73 20 70 6f 70 75 6c 61 74 65 64 20 77 69 74 is populated wit
81b0: 68 20 66 75 6e 63 74 69 6f 6e 20 74 6f 20 72 65 h function to re
81c0: 6d 6f 76 65 20 74 68 65 20 73 65 72 76 65 72 69 move the serveri
81d0: 6e 66 6f 20 66 69 6c 65 0a 28 64 65 66 69 6e 65 nfo file.(define
81e0: 20 28 74 74 3a 63 72 65 61 74 65 2d 73 65 72 76 (tt:create-serv
81f0: 65 72 2d 72 65 67 69 73 74 72 61 74 69 6f 6e 2d er-registration-
8200: 66 69 6c 65 20 74 74 64 61 74 20 64 62 66 6e 61 file ttdat dbfna
8210: 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 72 me). (let* ((ar
8220: 65 61 70 61 74 68 20 28 74 74 2d 61 72 65 61 70 eapath (tt-areap
8230: 61 74 68 20 74 74 64 61 74 29 29 0a 09 20 28 73 ath ttdat)).. (s
8240: 65 72 76 64 69 72 20 20 28 74 74 3a 67 65 74 2d ervdir (tt:get-
8250: 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 servinfo-dir are
8260: 61 70 61 74 68 29 29 0a 09 20 28 68 6f 73 74 20 apath)).. (host
8270: 20 20 20 20 28 74 74 2d 68 6f 73 74 20 74 74 64 (tt-host ttd
8280: 61 74 29 29 0a 09 20 28 70 6f 72 74 20 20 20 20 at)).. (port
8290: 20 28 74 74 2d 70 6f 72 74 20 74 74 64 61 74 29 (tt-port ttdat)
82a0: 29 0a 09 20 28 73 65 72 76 69 6e 66 20 28 63 6f ).. (servinf (co
82b0: 6e 63 20 73 65 72 76 64 69 72 22 2f 22 68 6f 73 nc servdir"/"hos
82c0: 74 22 3a 22 70 6f 72 74 22 2d 22 28 63 75 72 72 t":"port"-"(curr
82d0: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 ent-process-id)"
82e0: 3a 22 64 62 66 6e 61 6d 65 29 29 0a 09 20 28 73 :"dbfname)).. (s
82f0: 65 72 76 2d 69 64 20 28 74 74 3a 6d 6b 2d 73 69 erv-id (tt:mk-si
8300: 67 6e 61 74 75 72 65 20 61 72 65 61 70 61 74 68 gnature areapath
8310: 29 29 29 0a 20 20 20 20 28 61 73 73 65 72 74 20 ))). (assert
8320: 28 61 6e 64 20 68 6f 73 74 20 70 6f 72 74 29 20 (and host port)
8330: 22 46 41 54 41 4c 3a 20 74 74 3a 63 72 65 61 74 "FATAL: tt:creat
8340: 65 2d 73 65 72 76 65 72 2d 72 65 67 69 73 74 72 e-server-registr
8350: 61 74 69 6f 6e 2d 66 69 6c 65 20 63 61 6c 6c 65 ation-file calle
8360: 64 20 77 69 74 68 20 6e 6f 20 63 6f 6e 6e 2c 20 d with no conn,
8370: 64 62 66 6e 61 6d 65 3d 22 64 62 66 6e 61 6d 65 dbfname="dbfname
8380: 29 0a 20 20 20 20 28 74 74 2d 73 65 72 76 69 6e ). (tt-servin
8390: 66 2d 66 69 6c 65 2d 73 65 74 21 20 74 74 64 61 f-file-set! ttda
83a0: 74 20 73 65 72 76 69 6e 66 29 0a 20 20 20 20 28 t servinf). (
83b0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 with-output-to-f
83c0: 69 6c 65 20 73 65 72 76 69 6e 66 0a 20 20 20 20 ile servinf.
83d0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 70 (lambda ()..(p
83e0: 72 69 6e 74 20 22 53 45 52 56 45 52 20 53 54 41 rint "SERVER STA
83f0: 52 54 45 44 3a 20 22 68 6f 73 74 22 3a 22 70 6f RTED: "host":"po
8400: 72 74 22 20 41 54 20 22 28 63 75 72 72 65 6e 74 rt" AT "(current
8410: 2d 73 65 63 6f 6e 64 73 29 22 20 73 65 72 76 65 -seconds)" serve
8420: 72 2d 69 64 3a 20 22 73 65 72 76 2d 69 64 22 20 r-id: "serv-id"
8430: 70 69 64 3a 20 22 28 63 75 72 72 65 6e 74 2d 70 pid: "(current-p
8440: 72 6f 63 65 73 73 2d 69 64 29 22 20 64 62 66 6e rocess-id)" dbfn
8450: 61 6d 65 3a 20 22 64 62 66 6e 61 6d 65 29 29 29 ame: "dbfname)))
8460: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
8470: 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 (count 0)).
8480: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
8490: 65 78 69 73 74 73 3f 20 73 65 72 76 69 6e 66 29 exists? servinf)
84a0: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
84b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
84c0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
84d0: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 69 6c t* "WARNING: fil
84e0: 65 20 22 73 65 72 76 69 6e 66 22 20 77 61 73 20 e "servinf" was
84f0: 63 72 65 61 74 65 64 20 62 75 74 20 69 74 20 64 created but it d
8500: 6f 65 73 6e 27 74 20 73 68 6f 77 20 75 70 20 6f oesn't show up o
8510: 6e 20 64 69 73 6b 21 20 57 65 27 6c 6c 20 74 72 n disk! We'll tr
8520: 79 20 61 67 61 69 6e 2e 22 29 0a 09 20 20 20 20 y again.")..
8530: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
8540: 29 0a 09 20 20 20 20 28 69 66 20 28 3e 20 63 6f ).. (if (> co
8550: 75 6e 74 20 31 30 29 0a 09 09 28 64 65 62 75 67 unt 10)...(debug
8560: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
8570: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
8580: 4e 49 4e 47 3a 20 66 69 6c 65 20 22 73 65 72 76 NING: file "serv
8590: 69 6e 66 22 20 77 61 73 20 6e 6f 74 20 63 72 65 inf" was not cre
85a0: 61 74 65 64 2e 22 29 0a 09 09 28 6c 6f 6f 70 20 ated.")...(loop
85b0: 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 29 29 29 (+ count 1))))))
85c0: 0a 20 20 20 20 73 65 72 76 2d 69 64 29 29 0a 0a . serv-id))..
85d0: 3b 3b 20 66 69 6e 64 20 76 61 6c 69 64 20 73 65 ;; find valid se
85e0: 72 76 65 72 0a 3b 3b 20 67 65 74 20 73 65 72 76 rver.;; get serv
85f0: 65 72 73 20 6c 69 73 74 65 64 2c 20 6c 61 73 74 ers listed, last
8600: 20 70 61 72 74 20 6f 66 20 6e 61 6d 65 20 6d 75 part of name mu
8610: 73 74 20 6d 61 74 63 68 20 3a 3c 64 62 66 6e 61 st match :<dbfna
8620: 6d 65 3e 0a 3b 3b 20 69 66 20 6d 6f 72 65 20 74 me>.;; if more t
8630: 68 61 6e 20 6f 6e 65 2c 20 77 61 69 74 20 6f 6e han one, wait on
8640: 65 20 73 65 63 6f 6e 64 20 61 6e 64 20 6c 6f 6f e second and loo
8650: 6b 20 61 67 61 69 6e 0a 3b 3b 20 0a 3b 3b 20 4e k again.;; .;; N
8660: 4f 54 45 3a 20 74 68 69 73 20 6f 6e 6c 79 20 67 OTE: this only g
8670: 65 74 73 20 74 68 65 20 73 65 72 76 69 6e 66 6f ets the servinfo
8680: 20 64 61 74 61 2c 20 6e 6f 20 6e 65 74 77 6f 72 data, no networ
8690: 6b 20 61 63 74 69 76 69 74 79 20 68 65 72 65 0a k activity here.
86a0: 3b 3b 20 20 20 20 20 20 20 69 2e 65 2e 20 6e 6f ;; i.e. no
86b0: 20 70 69 6e 67 20 65 74 63 2e 0a 3b 3b 0a 28 64 ping etc..;;.(d
86c0: 65 66 69 6e 65 20 28 74 74 3a 66 69 6e 64 2d 73 efine (tt:find-s
86d0: 65 72 76 65 72 20 61 72 65 61 70 61 74 68 20 64 erver areapath d
86e0: 62 66 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 bfname). (let*
86f0: 28 28 73 65 72 76 64 69 72 20 20 28 74 74 3a 67 ((servdir (tt:g
8700: 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 et-servinfo-dir
8710: 61 72 65 61 70 61 74 68 29 29 0a 09 20 28 73 66 areapath)).. (sf
8720: 69 6c 65 73 20 20 20 28 67 6c 6f 62 20 28 63 6f iles (glob (co
8730: 6e 63 20 73 65 72 76 64 69 72 22 2f 2a 3a 22 64 nc servdir"/*:"d
8740: 62 66 6e 61 6d 65 29 29 29 0a 09 20 28 67 6f 6f bfname))).. (goo
8750: 64 66 69 6c 65 73 20 27 28 29 29 29 0a 0a 20 20 dfiles '()))..
8760: 20 20 3b 3b 20 66 69 6c 74 65 72 20 74 68 65 20 ;; filter the
8770: 66 69 6c 65 73 20 68 65 72 65 20 62 79 20 6c 6f files here by lo
8780: 6f 6b 69 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 oking in process
8790: 65 73 20 74 61 62 6c 65 20 28 69 66 20 77 65 20 es table (if we
87a0: 61 72 65 20 6e 6f 74 20 6d 61 69 6e 2e 64 62 29 are not main.db)
87b0: 0a 20 20 20 20 3b 3b 20 61 6e 64 20 6f 72 20 6c . ;; and or l
87c0: 6f 6f 6b 20 61 74 20 74 68 65 20 74 69 6d 65 20 ook at the time
87d0: 73 74 61 6d 70 20 6f 6e 20 74 68 65 20 73 65 72 stamp on the ser
87e0: 76 69 6e 66 6f 20 66 69 6c 65 2c 20 61 20 72 75 vinfo file, a ru
87f0: 6e 6e 69 6e 67 20 73 65 72 76 65 72 20 77 69 6c nning server wil
8800: 6c 0a 20 20 20 20 3b 3b 20 74 6f 75 63 68 20 74 l. ;; touch t
8810: 68 65 20 66 69 6c 65 20 65 76 65 72 79 20 6d 69 he file every mi
8820: 6e 75 74 65 20 28 61 67 61 69 6e 2c 20 74 68 69 nute (again, thi
8830: 73 20 77 69 6c 6c 20 6f 6e 6c 79 20 61 70 70 6c s will only appl
8840: 79 20 66 6f 72 20 6d 61 69 6e 2e 64 62 29 0a 20 y for main.db).
8850: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
8860: 6d 62 64 61 20 28 66 6e 61 6d 65 29 0a 09 09 28 mbda (fname)...(
8870: 6c 65 74 2a 20 28 28 61 67 65 20 28 2d 20 28 63 let* ((age (- (c
8880: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
8890: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
88a0: 6e 2d 74 69 6d 65 20 66 6e 61 6d 65 29 29 29 29 n-time fname))))
88b0: 0a 09 09 20 20 28 69 66 20 28 3e 20 61 67 65 20 ... (if (> age
88c0: 28 74 74 2d 73 65 72 76 65 72 2d 74 69 6d 65 6f (tt-server-timeo
88d0: 75 74 2d 70 61 72 61 6d 29 29 20 3b 3b 20 63 61 ut-param)) ;; ca
88e0: 6e 27 74 20 74 72 75 73 74 20 69 74 20 69 66 20 n't trust it if
88f0: 6f 76 65 72 20 73 65 72 76 65 72 20 74 69 6d 65 over server time
8900: 6f 75 74 20 6f 6c 64 2e 0a 09 09 20 20 20 20 20 out old....
8910: 20 28 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 (begin....(debu
8920: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
8930: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
8940: 52 4e 49 4e 47 3a 20 72 65 6d 6f 76 69 6e 67 20 RNING: removing
8950: 73 74 61 6c 65 20 73 65 72 76 69 6e 66 6f 20 66 stale servinfo f
8960: 69 6c 65 20 22 66 6e 61 6d 65 22 2c 20 69 74 20 ile "fname", it
8970: 69 73 20 22 61 67 65 22 20 73 65 63 6f 6e 64 73 is "age" seconds
8980: 20 6f 6c 64 22 29 0a 09 09 09 28 68 61 6e 64 6c old")....(handl
8990: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
89a0: 20 65 78 6e 0a 09 09 09 20 28 64 65 62 75 67 3a exn.... (debug:
89b0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
89c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e -log-port* "WARN
89d0: 49 4e 47 3a 20 65 72 72 6f 72 20 61 74 74 65 6d ING: error attem
89e0: 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 pting to remove
89f0: 73 74 61 6c 65 20 73 65 72 76 69 6e 66 6f 20 66 stale servinfo f
8a00: 69 6c 65 20 22 66 6e 61 6d 65 29 0a 09 09 09 20 ile "fname)....
8a10: 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 66 6e 61 (delete-file fna
8a20: 6d 65 29 29 29 20 3b 3b 20 0a 09 09 20 20 20 20 me))) ;; ...
8a30: 20 20 28 73 65 74 21 20 67 6f 6f 64 66 69 6c 65 (set! goodfile
8a40: 73 20 28 63 6f 6e 73 20 66 6e 61 6d 65 20 67 6f s (cons fname go
8a50: 6f 64 66 69 6c 65 73 29 29 29 29 29 0a 09 20 20 odfiles)))))..
8a60: 20 20 20 20 73 66 69 6c 65 73 29 0a 20 20 20 20 sfiles).
8a70: 67 6f 6f 64 66 69 6c 65 73 29 29 0a 0a 3b 3b 20 goodfiles))..;;
8a80: 67 69 76 65 6e 20 61 20 70 61 74 68 20 74 6f 20 given a path to
8a90: 61 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 69 a server info fi
8aa0: 6c 65 20 72 65 74 75 72 6e 3a 20 68 6f 73 74 20 le return: host
8ab0: 70 6f 72 74 20 73 74 61 72 74 73 65 63 6f 6e 64 port startsecond
8ac0: 73 20 73 65 72 76 65 72 2d 69 64 20 70 69 64 20 s server-id pid
8ad0: 64 62 66 6e 61 6d 65 20 6c 6f 67 66 0a 3b 3b 20 dbfname logf.;;
8ae0: 65 78 61 6d 70 6c 65 20 6f 66 20 77 68 61 74 20 example of what
8af0: 69 74 27 73 20 6c 6f 6f 6b 69 6e 67 20 66 6f 72 it's looking for
8b00: 20 69 6e 20 74 68 65 20 66 69 6c 65 3a 0a 3b 3b in the file:.;;
8b10: 20 20 20 20 20 53 45 52 56 45 52 20 53 54 41 52 SERVER STAR
8b20: 54 45 44 3a 20 31 30 2e 33 38 2e 31 37 35 2e 36 TED: 10.38.175.6
8b30: 37 3a 35 30 32 31 36 20 41 54 20 31 36 31 36 35 7:50216 AT 16165
8b40: 30 32 33 35 30 2e 30 20 73 65 72 76 65 72 2d 69 02350.0 server-i
8b50: 64 3a 20 34 39 30 37 65 39 30 66 63 35 35 63 37 d: 4907e90fc55c7
8b60: 61 30 39 36 39 34 65 33 66 36 35 38 63 36 33 39 a09694e3f658c639
8b70: 63 66 34 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 cf4 .;;.(define
8b80: 28 74 74 3a 73 65 72 76 65 72 2d 67 65 74 2d 69 (tt:server-get-i
8b90: 6e 66 6f 20 6c 6f 67 66 29 0a 20 20 28 6c 65 74 nfo logf). (let
8ba0: 20 28 28 73 65 72 76 65 72 2d 72 78 20 20 20 20 ((server-rx
8bb0: 28 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 52 (regexp "^SERVER
8bc0: 20 53 54 41 52 54 45 44 3a 20 28 5c 5c 53 2b 29 STARTED: (\\S+)
8bd0: 3a 28 5c 5c 64 2b 29 20 41 54 20 28 5b 5c 5c 64 :(\\d+) AT ([\\d
8be0: 5c 5c 2e 5d 2b 29 20 73 65 72 76 65 72 2d 69 64 \\.]+) server-id
8bf0: 3a 20 28 5c 5c 53 2b 29 20 70 69 64 3a 20 28 5c : (\\S+) pid: (\
8c00: 5c 64 2b 29 20 64 62 66 6e 61 6d 65 3a 20 28 5c \d+) dbfname: (\
8c10: 5c 53 2b 29 22 29 29 20 3b 3b 20 53 45 52 56 45 \S+)")) ;; SERVE
8c20: 52 20 53 54 41 52 54 45 44 3a 20 68 6f 73 74 3a R STARTED: host:
8c30: 70 6f 72 74 20 41 54 20 74 69 6d 65 73 65 63 73 port AT timesecs
8c40: 20 73 65 72 76 65 72 20 69 64 0a 09 28 62 61 64 server id..(bad
8c50: 2d 64 61 74 20 20 20 20 20 20 28 6c 69 73 74 20 -dat (list
8c60: 23 66 20 23 66 20 23 66 20 23 66 20 23 66 20 23 #f #f #f #f #f #
8c70: 66 20 6c 6f 67 66 29 29 29 0a 20 20 20 20 20 28 f logf))). (
8c80: 6c 65 74 20 28 28 66 64 61 74 20 20 20 20 20 28 let ((fdat (
8c90: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
8ca0: 73 0a 09 09 09 20 65 78 6e 0a 09 09 20 20 20 20 s.... exn...
8cb0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 3b 3b (begin.... ;;
8cc0: 20 42 55 47 2c 20 54 4f 44 4f 3a 20 61 64 64 20 BUG, TODO: add
8cd0: 65 72 72 20 63 68 65 63 6b 69 6e 67 2c 20 66 6f err checking, fo
8ce0: 72 20 6e 6f 77 20 62 6c 61 6e 6b 65 74 20 69 67 r now blanket ig
8cf0: 6e 6f 72 65 20 74 68 65 20 65 72 72 6f 72 73 3f nore the errors?
8d00: 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
8d10: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
8d20: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 61 t-log-port* "Una
8d30: 62 6c 65 20 74 6f 20 67 65 74 20 73 65 72 76 65 ble to get serve
8d40: 72 20 69 6e 66 6f 20 66 72 6f 6d 20 22 6c 6f 67 r info from "log
8d50: 66 0a 09 09 09 09 09 20 20 20 22 2c 20 65 78 6e f...... ", exn
8d60: 3d 22 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 ="(condition->li
8d70: 73 74 20 65 78 6e 29 29 0a 09 09 09 20 27 28 29 st exn)).... '()
8d80: 29 20 3b 3b 20 6e 6f 20 69 64 65 61 20 77 68 61 ) ;; no idea wha
8d90: 74 20 77 65 6e 74 20 77 72 6f 6e 67 2c 20 63 61 t went wrong, ca
8da0: 6c 6c 20 69 74 20 61 20 62 61 64 20 73 65 72 76 ll it a bad serv
8db0: 65 72 2c 20 72 65 74 75 72 6e 20 65 6d 70 74 79 er, return empty
8dc0: 20 6c 69 73 74 0a 09 09 20 20 20 20 20 20 20 28 list... (
8dd0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
8de0: 66 69 6c 65 20 6c 6f 67 66 20 72 65 61 64 2d 6c file logf read-l
8df0: 69 6e 65 73 29 29 29 29 0a 20 20 20 20 20 20 20 ines)))).
8e00: 28 69 66 20 28 6e 75 6c 6c 3f 20 66 64 61 74 29 (if (null? fdat)
8e10: 20 3b 3b 20 62 61 64 20 64 61 74 61 2c 20 72 65 ;; bad data, re
8e20: 74 75 72 6e 20 62 61 64 2d 64 61 74 0a 09 20 20 turn bad-dat..
8e30: 20 62 61 64 2d 64 61 74 0a 09 20 20 20 28 6c 65 bad-dat.. (le
8e40: 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 20 28 63 t loop ((inl (c
8e50: 61 72 20 66 64 61 74 29 29 0a 09 09 20 20 20 20 ar fdat))...
8e60: 20 20 28 74 61 69 6c 20 28 63 64 72 20 66 64 61 (tail (cdr fda
8e70: 74 29 29 0a 09 09 20 20 20 20 20 20 28 6c 6e 75 t))... (lnu
8e80: 6d 20 30 29 29 0a 09 20 20 20 20 20 28 6c 65 74 m 0)).. (let
8e90: 20 28 28 6d 6c 73 74 20 28 73 74 72 69 6e 67 2d ((mlst (string-
8ea0: 6d 61 74 63 68 20 73 65 72 76 65 72 2d 72 78 20 match server-rx
8eb0: 69 6e 6c 29 29 29 0a 09 20 20 20 20 20 20 20 28 inl))).. (
8ec0: 69 66 20 28 6e 6f 74 20 6d 6c 73 74 29 0a 09 09 if (not mlst)...
8ed0: 20 20 20 28 69 66 20 28 3e 20 6c 6e 75 6d 20 35 (if (> lnum 5
8ee0: 30 30 29 20 3b 3b 20 67 69 76 65 20 75 70 20 69 00) ;; give up i
8ef0: 66 20 6d 6f 72 65 20 74 68 61 6e 20 35 30 30 20 f more than 500
8f00: 6c 69 6e 65 73 20 6f 66 20 73 65 72 76 65 72 20 lines of server
8f10: 6c 6f 67 20 72 65 61 64 0a 09 09 20 20 20 20 20 log read...
8f20: 20 20 62 61 64 2d 64 61 74 0a 09 09 20 20 20 20 bad-dat...
8f30: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
8f40: 69 6c 29 0a 09 09 09 20 20 20 62 61 64 2d 64 61 il).... bad-da
8f50: 74 0a 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 63 t.... (loop (c
8f60: 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 61 69 ar tail)(cdr tai
8f70: 6c 29 28 2b 20 6c 6e 75 6d 20 31 29 29 29 29 0a l)(+ lnum 1)))).
8f80: 09 09 20 20 20 28 6d 61 74 63 68 20 6d 6c 73 74 .. (match mlst
8f90: 20 3b 3b 20 68 61 76 65 20 61 20 6e 6f 74 20 6e ;; have a not n
8fa0: 75 6c 6c 20 6c 69 73 74 0a 09 09 20 20 20 20 20 ull list...
8fb0: 28 28 5f 20 68 6f 73 74 20 70 6f 72 74 20 73 74 ((_ host port st
8fc0: 61 72 74 20 73 65 72 76 65 72 2d 69 64 20 70 69 art server-id pi
8fd0: 64 20 64 62 66 6e 61 6d 65 29 0a 09 09 20 20 20 d dbfname)...
8fe0: 20 20 20 28 6c 69 73 74 20 68 6f 73 74 0a 09 09 (list host...
8ff0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 . (string->nu
9000: 6d 62 65 72 20 70 6f 72 74 29 0a 09 09 09 20 20 mber port)....
9010: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
9020: 72 20 73 74 61 72 74 29 0a 09 09 09 20 20 20 20 r start)....
9030: 73 65 72 76 65 72 2d 69 64 0a 09 09 09 20 20 20 server-id....
9040: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
9050: 20 70 69 64 29 0a 09 09 09 20 20 20 20 64 62 66 pid).... dbf
9060: 6e 61 6d 65 0a 09 09 09 20 20 20 20 6c 6f 67 66 name.... logf
9070: 29 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 0a ))... (else.
9080: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
9090: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
90a0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
90b0: 3a 20 64 69 64 20 6e 6f 74 20 72 65 63 6f 67 6e : did not recogn
90c0: 69 73 65 20 53 45 52 56 45 52 20 6c 69 6e 65 20 ise SERVER line
90d0: 69 6e 66 6f 20 22 6d 6c 73 74 29 0a 09 09 20 20 info "mlst)...
90e0: 20 20 20 20 62 61 64 2d 64 61 74 29 29 29 29 29 bad-dat)))))
90f0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 6c ))))..(define *l
9100: 61 73 74 2d 73 65 72 76 65 72 2d 73 74 61 72 74 ast-server-start
9110: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
9120: 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 le))..(define (t
9130: 74 3a 74 6f 6f 2d 72 65 63 65 6e 74 2d 73 65 72 t:too-recent-ser
9140: 76 65 72 2d 73 74 61 72 74 20 64 62 66 6e 61 6d ver-start dbfnam
9150: 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 61 73 e). (let* ((las
9160: 74 2d 72 75 6e 2d 74 69 6d 65 20 28 68 61 73 68 t-run-time (hash
9170: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
9180: 6c 74 20 2a 6c 61 73 74 2d 73 65 72 76 65 72 2d lt *last-server-
9190: 73 74 61 72 74 2a 20 64 62 66 6e 61 6d 65 20 23 start* dbfname #
91a0: 66 29 29 29 0a 20 20 20 20 28 61 6e 64 20 6c 61 f))). (and la
91b0: 73 74 2d 72 75 6e 2d 74 69 6d 65 0a 09 20 28 3c st-run-time.. (<
91c0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
91d0: 6f 6e 64 73 29 20 6c 61 73 74 2d 72 75 6e 2d 74 onds) last-run-t
91e0: 69 6d 65 29 20 35 29 29 29 29 0a 0a 28 64 65 66 ime) 5))))..(def
91f0: 69 6e 65 20 2a 6c 61 73 74 2d 73 65 72 76 65 72 ine *last-server
9200: 2d 73 74 61 72 74 2d 72 65 71 75 65 73 74 2d 74 -start-request-t
9210: 69 6d 65 2a 20 30 29 0a 20 20 20 20 0a 3b 3b 20 ime* 0). .;;
9220: 47 69 76 65 6e 20 61 6e 20 61 72 65 61 20 70 61 Given an area pa
9230: 74 68 2c 20 20 73 74 61 72 74 20 61 20 73 65 72 th, start a ser
9240: 76 65 72 20 70 72 6f 63 65 73 73 20 20 20 20 23 ver process #
9250: 23 23 20 4e 4f 54 45 20 23 23 23 20 3e 20 66 69 ## NOTE ### > fi
9260: 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 69 66 20 74 le 2>&1 .;; if t
9270: 68 65 20 74 61 72 67 65 74 2d 68 6f 73 74 20 69 he target-host i
9280: 73 20 73 65 74 20 0a 3b 3b 20 74 72 79 20 72 75 s set .;; try ru
9290: 6e 6e 69 6e 67 20 6f 6e 20 74 68 61 74 20 68 6f nning on that ho
92a0: 73 74 0a 3b 3b 20 20 20 69 6e 63 69 64 65 6e 74 st.;; incident
92b0: 61 6c 3a 20 72 6f 74 61 74 65 20 6c 6f 67 73 20 al: rotate logs
92c0: 69 6e 20 6c 6f 67 73 2f 20 64 69 72 2e 0a 3b 3b in logs/ dir..;;
92d0: 0a 28 64 65 66 69 6e 65 20 20 28 74 74 3a 73 65 .(define (tt:se
92e0: 72 76 65 72 2d 70 72 6f 63 65 73 73 2d 72 75 6e rver-process-run
92f0: 20 61 72 65 61 70 61 74 68 20 74 65 73 74 73 75 areapath testsu
9300: 69 74 65 20 6d 74 65 78 65 20 72 75 6e 2d 69 64 ite mtexe run-id
9310: 20 23 21 6b 65 79 20 28 70 72 6f 66 69 6c 65 2d #!key (profile-
9320: 6d 6f 64 65 20 22 22 29 29 20 3b 3b 20 61 72 65 mode "")) ;; are
9330: 61 70 61 74 68 20 69 73 20 2a 74 6f 70 70 61 74 apath is *toppat
9340: 68 2a 20 66 6f 72 20 61 20 67 69 76 65 6e 20 74 h* for a given t
9350: 65 73 74 73 75 69 74 65 20 61 72 65 61 0a 20 20 estsuite area.
9360: 28 61 73 73 65 72 74 20 61 72 65 61 70 61 74 68 (assert areapath
9370: 20 20 22 46 41 54 41 4c 3a 20 74 74 3a 73 65 72 "FATAL: tt:ser
9380: 76 65 72 2d 70 72 6f 63 65 73 73 2d 72 75 6e 20 ver-process-run
9390: 63 61 6c 6c 65 64 20 77 69 74 68 6f 75 74 20 61 called without a
93a0: 72 65 61 70 61 74 68 20 64 65 66 69 6e 65 64 2e reapath defined.
93b0: 22 29 0a 20 20 28 61 73 73 65 72 74 20 74 65 73 "). (assert tes
93c0: 74 73 75 69 74 65 20 22 46 41 54 41 4c 3a 20 74 tsuite "FATAL: t
93d0: 74 3a 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 t:server-process
93e0: 2d 72 75 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 -run called with
93f0: 6f 75 74 20 74 65 73 74 73 75 69 74 65 20 64 65 out testsuite de
9400: 66 69 6e 65 64 2e 22 29 0a 20 20 28 61 73 73 65 fined."). (asse
9410: 72 74 20 6d 74 65 78 65 20 20 20 20 20 22 46 41 rt mtexe "FA
9420: 54 41 4c 3a 20 74 74 3a 73 65 72 76 65 72 2d 70 TAL: tt:server-p
9430: 72 6f 63 65 73 73 2d 72 75 6e 20 63 61 6c 6c 65 rocess-run calle
9440: 64 20 77 69 74 68 6f 75 74 20 6d 74 65 78 65 20 d without mtexe
9450: 64 65 66 69 6e 65 64 2e 22 29 0a 20 20 3b 3b 20 defined."). ;;
9460: 6d 74 65 73 74 20 2d 73 65 72 76 65 72 20 2d 20 mtest -server -
9470: 2d 6d 20 74 65 73 74 73 75 69 74 65 3a 65 78 74 -m testsuite:ext
9480: 2d 74 65 73 74 73 20 2d 64 62 20 36 2e 64 62 0a -tests -db 6.db.
9490: 20 20 28 6c 65 74 2a 20 28 28 64 62 66 6e 61 6d (let* ((dbfnam
94a0: 65 20 20 28 64 62 6d 6f 64 3a 72 75 6e 2d 69 64 e (dbmod:run-id
94b0: 2d 3e 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 ->dbfname run-id
94c0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 ))). (if (or
94d0: 28 3c 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (< (- (current-s
94e0: 65 63 6f 6e 64 73 29 20 2a 6c 61 73 74 2d 73 65 econds) *last-se
94f0: 72 76 65 72 2d 73 74 61 72 74 2d 72 65 71 75 65 rver-start-reque
9500: 73 74 2d 74 69 6d 65 2a 29 20 35 29 20 3b 3b 20 st-time*) 5) ;;
9510: 61 74 74 65 6d 70 74 65 64 20 73 74 61 72 74 20 attempted start
9520: 6c 65 73 73 20 74 68 61 6e 20 35 20 73 65 63 20 less than 5 sec
9530: 61 67 6f 0a 09 20 20 20 20 28 74 74 3a 74 6f 6f ago.. (tt:too
9540: 2d 72 65 63 65 6e 74 2d 73 65 72 76 65 72 2d 73 -recent-server-s
9550: 74 61 72 74 20 64 62 66 6e 61 6d 65 29 29 0a 09 tart dbfname))..
9560: 23 66 0a 09 28 6c 65 74 2a 20 28 28 6c 6f 61 64 #f..(let* ((load
9570: 20 20 20 20 20 28 67 65 74 2d 6e 6f 72 6d 61 6c (get-normal
9580: 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 29 29 0a ized-cpu-load)).
9590: 09 20 20 20 20 20 20 20 28 73 72 76 72 73 20 20 . (srvrs
95a0: 20 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 (tt:find-serve
95b0: 72 20 61 72 65 61 70 61 74 68 20 64 62 66 6e 61 r areapath dbfna
95c0: 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 74 72 me)).. (tr
95d0: 79 69 6e 67 20 20 20 28 6c 65 6e 67 74 68 20 73 ying (length s
95e0: 72 76 72 73 29 29 0a 09 20 20 20 20 20 20 20 28 rvrs)).. (
95f0: 6e 72 75 6e 20 20 20 20 20 28 6e 75 6d 62 65 72 nrun (number
9600: 2d 6f 66 2d 70 72 6f 63 65 73 73 65 73 2d 72 75 -of-processes-ru
9610: 6e 6e 69 6e 67 20 28 63 6f 6e 63 20 22 6d 74 65 nning (conc "mte
9620: 73 74 2e 2a 73 65 72 76 65 72 2e 2a 22 74 65 73 st.*server.*"tes
9630: 74 73 75 69 74 65 22 2e 2a 22 64 62 66 6e 61 6d tsuite".*"dbfnam
9640: 65 29 29 29 29 0a 09 20 20 28 73 65 74 21 20 2a e)))).. (set! *
9650: 6c 61 73 74 2d 73 65 72 76 65 72 2d 73 74 61 72 last-server-star
9660: 74 2d 72 65 71 75 65 73 74 2d 74 69 6d 65 2a 20 t-request-time*
9670: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
9680: 29 29 0a 09 20 20 28 63 6f 6e 64 0a 09 20 20 20 )).. (cond..
9690: 28 28 3e 20 6c 6f 61 64 20 34 2e 30 29 0a 09 20 ((> load 4.0)..
96a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
96b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
96c0: 6f 72 74 2a 20 22 4e 6f 72 6d 61 6c 69 7a 65 64 ort* "Normalized
96d0: 20 6c 6f 61 64 20 22 6c 6f 61 64 22 20 6f 6e 20 load "load" on
96e0: 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 " (get-host-name
96f0: 29 20 22 20 69 73 20 6f 76 65 72 20 74 68 65 20 ) " is over the
9700: 6c 69 6d 69 74 20 6f 66 20 34 2e 30 2e 20 4e 6f limit of 4.0. No
9710: 74 20 73 74 61 72 74 69 6e 67 20 61 20 73 65 72 t starting a ser
9720: 76 65 72 2e 20 50 6c 65 61 73 65 20 72 65 64 75 ver. Please redu
9730: 63 65 20 74 68 65 20 6c 6f 61 64 20 6f 6e 20 22 ce the load on "
9740: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 22 (get-host-name)"
9750: 20 62 79 20 6b 69 6c 6c 69 6e 67 20 73 6f 6d 65 by killing some
9760: 20 70 72 6f 63 65 73 73 65 73 22 29 0a 09 20 20 processes")..
9770: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
9780: 20 31 29 20 3b 3b 20 49 27 6d 20 6e 6f 74 20 63 1) ;; I'm not c
9790: 6f 6e 76 69 6e 63 65 64 20 74 68 61 74 20 61 20 onvinced that a
97a0: 64 65 6c 61 79 20 68 65 72 65 20 69 73 20 68 65 delay here is he
97b0: 6c 70 66 75 6c 2e 20 2d 6d 72 77 2d 0a 09 20 20 lpful. -mrw-..
97c0: 20 20 23 66 29 0a 09 20 20 20 28 28 3e 20 6e 72 #f).. ((> nr
97d0: 75 6e 20 31 30 30 29 0a 09 20 20 20 20 28 64 65 un 100).. (de
97e0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
97f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 6e ault-log-port* n
9800: 72 75 6e 22 20 73 65 72 76 65 72 73 20 72 75 6e run" servers run
9810: 6e 69 6e 67 20 6f 6e 20 22 20 28 67 65 74 2d 68 ning on " (get-h
9820: 6f 73 74 2d 6e 61 6d 65 29 20 22 2c 20 6e 6f 74 ost-name) ", not
9830: 20 73 74 61 72 74 69 6e 67 20 61 6e 6f 74 68 65 starting anothe
9840: 72 2e 22 29 0a 09 20 20 20 20 28 74 68 72 65 61 r.").. (threa
9850: 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 20 20 20 d-sleep! 1)..
9860: 20 23 66 29 0a 09 20 20 20 28 28 3e 20 74 72 79 #f).. ((> try
9870: 69 6e 67 20 33 29 0a 09 20 20 20 20 28 64 65 62 ing 3).. (deb
9880: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
9890: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 74 72 ult-log-port* tr
98a0: 79 69 6e 67 22 20 73 65 72 76 65 72 73 20 72 65 ying" servers re
98b0: 67 69 73 74 65 72 65 64 20 69 6e 20 2e 73 65 72 gistered in .ser
98c0: 76 69 6e 66 6f 20 64 69 72 2e 20 6e 6f 74 20 73 vinfo dir. not s
98d0: 74 61 72 74 69 6e 67 20 61 6e 6f 74 68 65 72 2e tarting another.
98e0: 22 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d ").. (thread-
98f0: 73 6c 65 65 70 21 20 31 29 0a 09 20 20 20 20 23 sleep! 1).. #
9900: 66 29 0a 09 20 20 20 28 65 6c 73 65 0a 09 20 20 f).. (else..
9910: 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 (if (not (file
9920: 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 61 -exists? (conc a
9930: 72 65 61 70 61 74 68 22 2f 6c 6f 67 73 22 29 29 reapath"/logs"))
9940: 29 0a 09 09 28 63 72 65 61 74 65 2d 64 69 72 65 )...(create-dire
9950: 63 74 6f 72 79 20 28 63 6f 6e 63 20 61 72 65 61 ctory (conc area
9960: 70 61 74 68 22 2f 6c 6f 67 73 22 29 20 23 74 29 path"/logs") #t)
9970: 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 6c ).. (let* ((l
9980: 6f 67 66 69 6c 65 20 20 20 28 63 6f 6e 63 20 61 ogfile (conc a
9990: 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 73 2f 73 reapath "/logs/s
99a0: 65 72 76 65 72 2d 22 64 62 66 6e 61 6d 65 22 2d erver-"dbfname"-
99b0: 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 "(current-proces
99c0: 73 2d 69 64 29 22 2e 6c 6f 67 22 29 29 20 3b 3b s-id)".log")) ;;
99d0: 20 2d 22 20 63 75 72 72 2d 70 69 64 20 22 2d 22 -" curr-pid "-"
99e0: 20 74 61 72 67 65 74 2d 68 6f 73 74 20 22 2e 6c target-host ".l
99f0: 6f 67 22 29 29 0a 09 09 20 20 20 28 63 6d 64 6c og"))... (cmdl
9a00: 6e 20 28 63 6f 6e 63 0a 09 09 09 20 20 20 20 20 n (conc....
9a10: 20 20 6d 74 65 78 65 0a 09 09 09 20 20 20 20 20 mtexe....
9a20: 20 20 22 20 2d 73 74 61 72 74 64 69 72 20 22 61 " -startdir "a
9a30: 72 65 61 70 61 74 68 0a 09 09 09 20 20 20 20 20 reapath....
9a40: 20 20 22 20 2d 73 65 72 76 65 72 20 2d 20 22 3b " -server - ";
9a50: 3b 20 28 6f 72 20 74 61 72 67 65 74 2d 68 6f 73 ; (or target-hos
9a60: 74 20 22 2d 22 29 0a 09 09 09 20 20 20 20 20 20 t "-")....
9a70: 20 22 20 2d 6d 20 74 65 73 74 73 75 69 74 65 3a " -m testsuite:
9a80: 22 74 65 73 74 73 75 69 74 65 0a 09 09 09 20 20 "testsuite....
9a90: 20 20 20 20 20 22 20 2d 64 62 20 22 64 62 66 6e " -db "dbfn
9aa0: 61 6d 65 20 3b 3b 20 28 64 62 6d 6f 64 3a 72 75 ame ;; (dbmod:ru
9ab0: 6e 2d 69 64 2d 3e 64 62 66 6e 61 6d 65 20 72 75 n-id->dbfname ru
9ac0: 6e 2d 69 64 29 0a 09 09 09 20 20 20 20 20 20 20 n-id)....
9ad0: 22 20 22 20 70 72 6f 66 69 6c 65 2d 6d 6f 64 65 " " profile-mode
9ae0: 0a 09 09 09 20 20 20 20 20 20 20 23 3b 28 63 6f .... #;(co
9af0: 6e 63 20 22 20 3e 3e 20 22 20 6c 6f 67 66 69 6c nc " >> " logfil
9b00: 65 20 22 20 32 3e 26 31 20 26 22 29 29 29 29 0a e " 2>&1 &")))).
9b10: 09 20 20 20 20 20 20 3b 3b 20 77 65 20 77 61 6e . ;; we wan
9b20: 74 20 74 68 65 20 72 65 6d 6f 74 65 20 73 65 72 t the remote ser
9b30: 76 65 72 20 74 6f 20 73 74 61 72 74 20 69 6e 20 ver to start in
9b40: 2a 74 6f 70 70 61 74 68 2a 20 73 6f 20 70 75 73 *toppath* so pus
9b50: 68 20 74 68 65 72 65 0a 09 20 20 20 20 20 20 3b h there.. ;
9b60: 3b 20 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 ; (push-director
9b70: 79 20 61 72 65 61 70 61 74 68 29 20 3b 3b 20 75 y areapath) ;; u
9b80: 73 65 20 63 64 20 69 6e 20 74 68 65 20 63 6f 6d se cd in the com
9b90: 6d 61 6e 64 20 6c 69 6e 65 20 69 6e 73 74 65 61 mand line instea
9ba0: 64 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a d.. (debug:
9bb0: 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 print 2 *default
9bc0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
9bd0: 3a 20 54 72 79 69 6e 67 20 74 6f 20 73 74 61 72 : Trying to star
9be0: 74 20 73 65 72 76 65 72 20 69 6e 20 74 63 70 20 t server in tcp
9bf0: 6d 6f 64 65 20 28 22 20 63 6d 64 6c 6e 20 22 29 mode (" cmdln ")
9c00: 20 61 74 20 22 28 63 6f 6d 6d 6f 6e 3a 68 75 6d at "(common:hum
9c10: 61 6e 2d 74 69 6d 65 29 22 20 66 6f 72 20 22 61 an-time)" for "a
9c20: 72 65 61 70 61 74 68 29 0a 09 20 20 20 20 20 20 reapath)..
9c30: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
9c40: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
9c50: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 73 74 61 72 ort* "INFO: star
9c60: 74 69 6e 67 20 73 65 72 76 65 72 20 61 74 20 22 ting server at "
9c70: 20 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 (common:human-t
9c80: 69 6d 65 29 29 0a 0a 09 20 20 20 20 20 20 28 73 ime))... (s
9c90: 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 5f 51 55 etenv "NBFAKE_QU
9ca0: 49 45 54 22 20 22 79 65 73 22 29 20 3b 3b 20 42 IET" "yes") ;; B
9cb0: 55 47 3a 20 63 68 61 6e 67 65 20 74 6f 20 77 69 UG: change to wi
9cc0: 74 68 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 th-environment-v
9cd0: 61 72 69 61 62 6c 65 20 2e 2e 2e 0a 09 20 20 20 ariable .....
9ce0: 20 20 20 28 73 65 74 65 6e 76 20 22 4e 42 46 41 (setenv "NBFA
9cf0: 4b 45 5f 4c 4f 47 22 20 6c 6f 67 66 69 6c 65 29 KE_LOG" logfile)
9d00: 0a 09 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 .. (system
9d10: 28 63 6f 6e 63 20 22 63 64 20 22 61 72 65 61 70 (conc "cd "areap
9d20: 61 74 68 22 20 3b 20 6e 62 66 61 6b 65 20 22 20 ath" ; nbfake "
9d30: 63 6d 64 6c 6e 29 29 0a 09 20 20 20 20 20 20 28 cmdln)).. (
9d40: 75 6e 73 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 unsetenv "NBFAKE
9d50: 5f 51 55 49 45 54 22 29 0a 09 20 20 20 20 20 20 _QUIET")..
9d60: 28 75 6e 73 65 74 65 6e 76 20 22 4e 42 46 41 4b (unsetenv "NBFAK
9d70: 45 5f 4c 4f 47 22 29 0a 09 20 20 20 20 20 20 3b E_LOG").. ;
9d80: 3b 20 28 73 79 73 74 65 6d 20 63 6d 64 6c 6e 29 ; (system cmdln)
9d90: 0a 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 .. (hash-ta
9da0: 62 6c 65 2d 73 65 74 21 20 2a 6c 61 73 74 2d 73 ble-set! *last-s
9db0: 65 72 76 65 72 2d 73 74 61 72 74 2a 20 64 62 66 erver-start* dbf
9dc0: 6e 61 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 name (current-se
9dd0: 63 6f 6e 64 73 29 29 0a 09 20 20 20 20 20 20 3b conds)).. ;
9de0: 3b 20 3b 3b 20 75 73 65 20 62 65 6c 6f 77 20 74 ; ;; use below t
9df0: 6f 20 67 6f 20 62 61 63 6b 20 74 6f 20 6e 62 66 o go back to nbf
9e00: 61 6b 65 20 2d 20 6e 62 66 61 6b 65 20 64 6f 65 ake - nbfake doe
9e10: 73 20 63 61 75 73 65 20 74 72 6f 75 62 6c 65 20 s cause trouble
9e20: 2e 2e 2e 0a 09 20 20 20 20 20 20 3b 3b 20 28 73 ..... ;; (s
9e30: 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 5f 51 55 etenv "NBFAKE_QU
9e40: 49 45 54 22 20 22 79 65 73 22 29 20 3b 3b 20 42 IET" "yes") ;; B
9e50: 55 47 3a 20 63 68 61 6e 67 65 20 74 6f 20 77 69 UG: change to wi
9e60: 74 68 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 th-environment-v
9e70: 61 72 69 61 62 6c 65 20 2e 2e 2e 0a 09 20 20 20 ariable .....
9e80: 20 20 20 3b 3b 20 28 73 65 74 65 6e 76 20 22 4e ;; (setenv "N
9e90: 42 46 41 4b 45 5f 4c 4f 47 22 20 6c 6f 67 66 69 BFAKE_LOG" logfi
9ea0: 6c 65 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 73 le).. ;; (s
9eb0: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 63 64 20 ystem (conc "cd
9ec0: 22 61 72 65 61 70 61 74 68 22 20 3b 20 6e 62 66 "areapath" ; nbf
9ed0: 61 6b 65 20 22 20 63 6d 64 6c 6e 29 29 0a 09 20 ake " cmdln))..
9ee0: 20 20 20 20 20 3b 3b 20 28 75 6e 73 65 74 65 6e ;; (unseten
9ef0: 76 20 22 4e 42 46 41 4b 45 5f 51 55 49 45 54 22 v "NBFAKE_QUIET"
9f00: 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 75 6e 73 ).. ;; (uns
9f10: 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 5f 4c 4f etenv "NBFAKE_LO
9f20: 47 22 29 0a 09 20 20 20 20 20 20 0a 09 20 20 20 G").. ..
9f30: 20 20 20 3b 3b 28 70 6f 70 2d 64 69 72 65 63 74 ;;(pop-direct
9f40: 6f 72 79 29 0a 09 20 20 20 20 20 20 23 74 29 29 ory).. #t))
9f50: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
9f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
9fa0: 3b 3b 20 74 63 70 20 63 6f 6e 6e 65 63 74 69 6f ;; tcp connectio
9fb0: 6e 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d 3d 3d n stuff.;;======
9fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a000: 0a 0a 3b 3b 20 66 69 6e 64 20 61 20 70 6f 72 74 ..;; find a port
a010: 20 61 6e 64 20 73 74 61 72 74 20 74 63 70 2d 73 and start tcp-s
a020: 65 72 76 65 72 2e 20 54 68 69 73 20 6f 6e 6c 79 erver. This only
a030: 20 73 74 61 72 74 73 20 74 68 65 20 74 63 70 20 starts the tcp
a040: 70 6f 72 74 69 6f 6e 20 6f 66 0a 3b 3b 20 74 68 portion of.;; th
a050: 65 20 73 65 72 76 65 72 2c 20 6c 6f 6f 6b 20 61 e server, look a
a060: 74 20 28 74 74 3a 73 74 61 72 74 2d 73 65 72 76 t (tt:start-serv
a070: 65 72 20 2e 2e 2e 29 20 61 62 6f 76 65 20 66 6f er ...) above fo
a080: 72 20 74 68 65 20 65 6e 74 72 79 20 70 6f 69 6e r the entry poin
a090: 74 0a 3b 3b 20 66 6f 72 20 74 68 65 20 65 6e 74 t.;; for the ent
a0a0: 69 72 65 20 73 65 72 76 65 72 20 73 79 73 74 65 ire server syste
a0b0: 6d 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 74 m.;;.(define (tt
a0c0: 3a 73 74 61 72 74 2d 74 63 70 2d 73 65 72 76 65 :start-tcp-serve
a0d0: 72 20 74 74 64 61 74 29 0a 20 20 28 73 65 74 75 r ttdat). (setu
a0e0: 70 2d 6c 69 73 74 65 6e 65 72 2d 70 6f 72 74 6c p-listener-portl
a0f0: 6f 67 67 65 72 20 74 74 64 61 74 29 20 3b 3b 20 ogger ttdat) ;;
a100: 73 65 74 20 75 70 20 74 63 70 2d 6c 69 73 74 65 set up tcp-liste
a110: 6e 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 73 6f ner. (let* ((so
a120: 63 6b 65 74 20 20 20 28 74 74 2d 73 6f 63 6b 65 cket (tt-socke
a130: 74 20 20 74 74 64 61 74 29 29 0a 09 20 28 68 61 t ttdat)).. (ha
a140: 6e 64 6c 65 72 20 20 28 74 74 2d 68 61 6e 64 6c ndler (tt-handl
a150: 65 72 20 74 74 64 61 74 29 29 20 3b 3b 20 74 68 er ttdat)) ;; th
a160: 65 20 68 61 6e 64 6c 65 72 20 63 6f 6d 65 73 20 e handler comes
a170: 66 72 6f 6d 20 6f 75 72 20 63 6c 69 65 6e 74 20 from our client
a180: 73 65 74 74 69 6e 67 20 61 20 68 61 6e 64 6c 65 setting a handle
a190: 72 20 66 75 6e 63 74 69 6f 6e 0a 09 20 28 68 61 r function.. (ha
a1a0: 6e 64 6c 65 72 2d 70 72 6f 63 20 28 6c 61 6d 62 ndler-proc (lamb
a1b0: 64 61 20 28 29 0a 09 09 09 20 28 6c 65 74 2a 20 da ().... (let*
a1c0: 28 28 69 6e 64 61 74 20 20 20 20 20 20 20 20 20 ((indat
a1d0: 28 64 65 73 65 72 69 61 6c 69 7a 65 29 29 20 3b (deserialize)) ;
a1e0: 3b 20 63 6f 75 6c 64 20 75 73 65 3a 20 28 74 68 ; could use: (th
a1f0: 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 20 read-terminate!
a200: 28 63 75 72 72 65 6e 74 2d 74 68 72 65 61 64 29 (current-thread)
a210: 29 0a 09 09 09 09 28 72 65 73 75 6c 74 20 20 20 ).....(result
a220: 20 20 20 20 20 23 66 29 0a 09 09 09 09 28 65 78 #f).....(ex
a230: 6e 2d 72 65 73 75 6c 74 20 20 20 20 23 66 29 0a n-result #f).
a240: 09 09 09 09 28 73 74 64 6f 75 74 2d 72 65 73 75 ....(stdout-resu
a250: 6c 74 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d lt (with-output-
a260: 74 6f 2d 73 74 72 69 6e 67 0a 09 09 09 09 09 09 to-string.......
a270: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 (lambda ().....
a280: 09 09 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 .. (let ((res
a290: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
a2a0: 6e 73 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 ns........
a2b0: 20 65 78 6e 0a 09 09 09 09 09 09 09 20 20 20 20 exn........
a2c0: 20 20 20 28 6c 65 74 2a 20 28 28 65 72 72 64 61 (let* ((errda
a2d0: 74 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 t (condition->li
a2e0: 73 74 20 65 78 6e 29 29 29 0a 09 09 09 09 09 09 st exn))).......
a2f0: 09 09 20 28 73 65 74 21 20 65 78 6e 2d 72 65 73 .. (set! exn-res
a300: 75 6c 74 20 65 72 72 64 61 74 29 0a 09 09 09 09 ult errdat).....
a310: 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
a320: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
a330: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 68 -port* "ERROR: h
a340: 61 6e 64 6c 65 72 20 65 78 63 65 70 74 69 6f 6e andler exception
a350: 2c 20 74 68 65 73 65 20 61 72 65 20 62 61 64 2c , these are bad,
a360: 20 77 69 6c 6c 20 65 78 69 74 20 69 6e 20 66 69 will exit in fi
a370: 76 65 20 73 65 63 6f 6e 64 73 2e 22 29 0a 09 09 ve seconds.")...
a380: 09 09 09 09 09 09 20 28 70 70 20 65 72 72 64 61 ...... (pp errda
a390: 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 t *default-log-p
a3a0: 6f 72 74 2a 29 0a 09 09 09 09 09 09 09 09 20 3b ort*)......... ;
a3b0: 3b 20 74 68 65 73 65 20 61 72 65 20 61 6c 77 61 ; these are alwa
a3c0: 79 73 20 62 61 64 2c 20 73 65 74 20 75 70 20 61 ys bad, set up a
a3d0: 6e 20 65 78 69 74 20 74 68 72 65 61 64 0a 09 09 n exit thread...
a3e0: 09 09 09 09 09 09 20 28 74 68 72 65 61 64 2d 73 ...... (thread-s
a3f0: 74 61 72 74 21 20 28 6d 61 6b 65 2d 74 68 72 65 tart! (make-thre
a400: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ad (lambda ()...
a410: 09 09 09 09 09 20 20 20 20 20 20 09 09 09 09 20 ..... ....
a420: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
a430: 65 65 70 21 20 35 29 0a 09 09 09 09 09 09 09 20 eep! 5)........
a440: 20 20 20 20 20 09 09 09 09 20 20 20 20 20 20 20 ....
a450: 28 65 78 69 74 29 29 29 29 0a 09 09 09 09 09 09 (exit)))).......
a460: 09 20 20 20 20 20 20 20 23 66 29 0a 09 09 09 09 . #f).....
a470: 09 09 09 09 28 68 61 6e 64 6c 65 72 20 69 6e 64 ....(handler ind
a480: 61 74 29 20 3b 3b 20 74 68 69 73 20 69 73 20 74 at) ;; this is t
a490: 68 65 20 70 72 6f 63 20 62 65 69 6e 67 20 63 61 he proc being ca
a4a0: 6c 6c 65 64 20 62 79 20 74 68 65 20 72 65 6d 6f lled by the remo
a4b0: 74 65 20 63 6c 69 65 6e 74 0a 09 09 09 09 09 09 te client.......
a4c0: 09 09 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 ..))).......
a4d0: 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 72 65 (set! result re
a4e0: 73 29 29 29 29 29 0a 09 09 09 09 28 66 75 6c 6c s))))).....(full
a4f0: 2d 72 65 73 75 6c 74 20 20 20 20 28 6c 69 73 74 -result (list
a500: 20 72 65 73 75 6c 74 20 65 78 6e 2d 72 65 73 75 result exn-resu
a510: 6c 74 20 28 69 66 20 28 65 71 75 61 6c 3f 20 73 lt (if (equal? s
a520: 74 64 6f 75 74 2d 72 65 73 75 6c 74 20 22 22 29 tdout-result "")
a530: 20 23 66 20 73 74 64 6f 75 74 2d 72 65 73 75 6c #f stdout-resul
a540: 74 29 29 29 29 0a 09 09 09 20 20 20 28 68 61 6e t)))).... (han
a550: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
a560: 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 09 09 .. exn....
a570: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 (begin....
a580: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
a590: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
a5a0: 67 2d 70 6f 72 74 2a 20 22 53 65 72 69 61 6c 69 g-port* "Seriali
a5b0: 7a 61 74 69 6f 6e 20 66 61 69 6c 75 72 65 2e 20 zation failure.
a5c0: 66 75 6c 6c 2d 72 65 73 75 6c 74 3d 22 66 75 6c full-result="ful
a5d0: 6c 2d 72 65 73 75 6c 74 29 0a 09 09 09 20 20 20 l-result)....
a5e0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
a5f0: 74 21 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 t! (make-thread
a600: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 (lambda ()......
a610: 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 .. (thread-s
a620: 6c 65 65 70 21 20 35 29 0a 09 09 09 09 09 09 09 leep! 5)........
a630: 20 20 20 20 20 28 65 78 69 74 29 29 29 29 29 20 (exit)))))
a640: 20 20 20 3b 3b 20 28 73 65 72 69 61 6c 69 7a 65 ;; (serialize
a650: 20 27 28 23 66 20 23 66 20 23 66 29 29 20 3b 3b '(#f #f #f)) ;;
a660: 20 64 6f 65 73 6e 27 74 20 77 6f 72 6b 20 2d 20 doesn't work -
a670: 74 68 65 20 66 69 72 73 74 20 63 61 6c 6c 20 74 the first call t
a680: 6f 20 73 65 72 69 61 6c 69 7a 65 20 63 61 75 73 o serialize caus
a690: 65 64 20 66 61 69 6c 75 72 65 0a 09 09 09 20 20 ed failure....
a6a0: 20 20 20 28 73 65 72 69 61 6c 69 7a 65 20 66 75 (serialize fu
a6b0: 6c 6c 2d 72 65 73 75 6c 74 29 29 29 29 29 29 0a ll-result)))))).
a6c0: 20 20 20 20 28 28 6d 61 6b 65 2d 74 63 70 2d 73 ((make-tcp-s
a6d0: 65 72 76 65 72 20 73 6f 63 6b 65 74 20 68 61 6e erver socket han
a6e0: 64 6c 65 72 2d 70 72 6f 63 29 0a 20 20 20 20 20 dler-proc).
a6f0: 23 66 20 3b 3b 20 79 65 73 2c 20 73 65 6e 64 20 #f ;; yes, send
a700: 65 72 72 6f 72 20 6d 65 73 73 61 67 65 73 20 74 error messages t
a710: 6f 20 73 74 64 2d 65 72 72 0a 20 20 20 20 20 29 o std-err. )
a720: 29 29 0a 0a 3b 3b 20 63 72 65 61 74 65 20 61 20 ))..;; create a
a730: 74 63 70 20 6c 69 73 74 65 6e 65 72 20 61 6e 64 tcp listener and
a740: 20 72 65 74 75 72 6e 20 61 20 70 6f 70 75 6c 61 return a popula
a750: 74 65 64 20 75 64 61 74 20 73 74 72 75 63 74 20 ted udat struct
a760: 77 69 74 68 0a 3b 3b 20 6d 79 20 70 6f 72 74 2c with.;; my port,
a770: 20 61 64 64 72 65 73 73 2c 20 68 6f 73 74 6e 61 address, hostna
a780: 6d 65 2c 20 70 69 64 20 65 74 63 2e 0a 3b 3b 20 me, pid etc..;;
a790: 72 65 74 75 72 6e 20 23 66 20 69 66 20 66 61 69 return #f if fai
a7a0: 6c 20 74 6f 20 66 69 6e 64 20 61 20 70 6f 72 74 l to find a port
a7b0: 20 74 6f 20 61 6c 6c 6f 63 61 74 65 2e 0a 3b 3b to allocate..;;
a7c0: 0a 3b 3b 20 20 69 66 20 75 64 61 74 61 2d 69 6e .;; if udata-in
a7d0: 20 69 73 20 23 66 20 63 72 65 61 74 65 20 74 68 is #f create th
a7e0: 65 20 72 65 63 6f 72 64 0a 3b 3b 20 20 69 66 20 e record.;; if
a7f0: 74 68 65 72 65 20 69 73 20 61 6c 72 65 61 64 79 there is already
a800: 20 61 20 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 a serv-listener
a810: 20 72 65 74 75 72 6e 20 74 68 65 20 75 64 61 74 return the udat
a820: 61 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 a.;;.;; (define
a830: 28 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 (setup-listener
a840: 75 63 6f 6e 6e 20 23 21 6f 70 74 69 6f 6e 61 6c uconn #!optional
a850: 20 28 70 6f 72 74 20 34 32 34 32 29 29 0a 3b 3b (port 4242)).;;
a860: 20 20 20 28 61 73 73 65 72 74 20 28 74 74 3f 20 (assert (tt?
a870: 75 63 6f 6e 6e 29 20 22 46 41 54 41 4c 3a 20 73 uconn) "FATAL: s
a880: 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 63 61 etup-listener ca
a890: 6c 6c 65 64 20 77 69 74 68 20 77 72 6f 6e 67 20 lled with wrong
a8a0: 73 74 72 75 63 74 20 22 75 63 6f 6e 6e 29 0a 3b struct "uconn).;
a8b0: 3b 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ; (handle-exce
a8c0: 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 20 65 78 6e ptions.;; exn
a8d0: 0a 3b 3b 20 20 20 20 28 69 66 20 28 3c 20 70 6f .;; (if (< po
a8e0: 72 74 20 36 35 35 33 35 29 0a 3b 3b 20 20 20 20 rt 65535).;;
a8f0: 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 09 20 (begin.;; .
a900: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
a910: 2e 32 35 29 0a 3b 3b 20 09 20 28 73 65 74 75 70 .25).;; . (setup
a920: 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e 6e 20 -listener uconn
a930: 28 2b 20 70 6f 72 74 20 31 29 29 29 0a 3b 3b 20 (+ port 1))).;;
a940: 20 20 20 20 20 20 20 23 66 29 0a 3b 3b 20 20 20 #f).;;
a950: 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 74 65 6e (connect-listen
a960: 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 29 29 29 er uconn port)))
a970: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 75 70 ..(define (setup
a980: 2d 6c 69 73 74 65 6e 65 72 2d 70 6f 72 74 6c 6f -listener-portlo
a990: 67 67 65 72 20 75 63 6f 6e 6e 29 0a 20 20 28 6c gger uconn). (l
a9a0: 65 74 20 28 28 70 6f 72 74 20 28 70 6f 72 74 6c et ((port (portl
a9b0: 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 ogger:open-run-c
a9c0: 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a lose portlogger:
a9d0: 66 69 6e 64 2d 70 6f 72 74 29 29 29 0a 20 20 20 find-port))).
a9e0: 20 28 61 73 73 65 72 74 20 28 74 74 3f 20 75 63 (assert (tt? uc
a9f0: 6f 6e 6e 29 20 22 46 41 54 41 4c 3a 20 73 65 74 onn) "FATAL: set
aa00: 75 70 2d 6c 69 73 74 65 6e 65 72 20 63 61 6c 6c up-listener call
aa10: 65 64 20 77 69 74 68 20 77 72 6f 6e 67 20 73 74 ed with wrong st
aa20: 72 75 63 74 20 22 75 63 6f 6e 6e 29 0a 20 20 20 ruct "uconn).
aa30: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
aa40: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
aa50: 74 2a 20 22 73 65 74 75 70 2d 6c 69 73 74 65 6e t* "setup-listen
aa60: 65 72 2d 70 6f 72 74 6c 6f 67 67 65 72 20 67 6f er-portlogger go
aa70: 74 20 70 6f 72 74 20 22 20 70 6f 72 74 29 0a 20 t port " port).
aa80: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
aa90: 74 69 6f 6e 73 0a 09 65 78 6e 0a 20 20 20 20 20 tions..exn.
aaa0: 20 28 69 66 20 28 3c 20 70 6f 72 74 20 36 35 35 (if (< port 655
aab0: 33 35 29 0a 09 20 20 28 62 65 67 69 6e 0a 20 20 35).. (begin.
aac0: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
aad0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
aae0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 74 t-log-port* "set
aaf0: 75 70 2d 6c 69 73 74 65 6e 65 72 2d 70 6f 72 74 up-listener-port
ab00: 6c 6f 67 67 65 72 3a 20 65 78 63 65 70 74 69 6f logger: exceptio
ab10: 6e 20 66 69 6e 64 69 6e 67 20 70 6f 72 74 2e 20 n finding port.
ab20: 52 65 74 72 79 69 6e 67 22 29 0a 09 20 20 20 20 Retrying")..
ab30: 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e (portlogger:open
ab40: 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c -run-close portl
ab50: 6f 67 67 65 72 3a 73 65 74 2d 66 61 69 6c 65 64 ogger:set-failed
ab60: 20 70 6f 72 74 29 0a 09 20 20 20 20 28 74 68 72 port).. (thr
ab70: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 ead-sleep! 0.25)
ab80: 0a 09 20 20 20 20 28 73 65 74 75 70 2d 6c 69 73 .. (setup-lis
ab90: 74 65 6e 65 72 2d 70 6f 72 74 6c 6f 67 67 65 72 tener-portlogger
aba0: 20 75 63 6f 6e 6e 29 29 0a 20 20 20 20 20 20 20 uconn)).
abb0: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
abc0: 20 20 20 20 20 20 28 61 73 73 65 72 74 20 23 74 (assert #t
abd0: 20 22 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 "setup-listener
abe0: 2d 70 6f 72 74 6c 6f 67 67 65 72 3a 20 63 6f 75 -portlogger: cou
abf0: 6c 64 20 6e 6f 74 20 67 65 74 20 61 20 70 6f 72 ld not get a por
ac00: 74 22 29 0a 09 20 20 20 20 23 66 0a 20 20 20 20 t").. #f.
ac10: 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 29 0a ). ).
ac20: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
ac30: 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 2 *default-lo
ac40: 67 2d 70 6f 72 74 2a 20 22 73 65 74 75 70 2d 6c g-port* "setup-l
ac50: 69 73 74 65 6e 65 72 2d 70 6f 72 74 6c 6f 67 67 istener-portlogg
ac60: 65 72 3a 20 67 6f 74 20 70 6f 72 74 20 22 20 70 er: got port " p
ac70: 6f 72 74 29 0a 20 20 20 20 20 20 28 63 6f 6e 6e ort). (conn
ac80: 65 63 74 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f ect-listener uco
ac90: 6e 6e 20 70 6f 72 74 29 29 29 29 0a 0a 28 64 65 nn port))))..(de
aca0: 66 69 6e 65 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 fine (connect-li
acb0: 73 74 65 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 stener uconn por
acc0: 74 29 0a 20 20 3b 3b 20 28 74 63 70 2d 6c 69 73 t). ;; (tcp-lis
acd0: 74 65 6e 65 72 2d 73 6f 63 6b 65 74 20 4c 49 53 tener-socket LIS
ace0: 54 45 4e 45 52 29 28 73 6f 63 6b 65 74 2d 6e 61 TENER)(socket-na
acf0: 6d 65 20 73 6f 29 0a 20 20 3b 3b 20 73 6f 63 6b me so). ;; sock
ad00: 61 64 64 72 2d 61 64 64 72 65 73 73 2c 20 73 6f addr-address, so
ad10: 63 6b 61 64 64 72 2d 70 6f 72 74 2c 20 73 6f 63 ckaddr-port, soc
ad20: 6b 61 64 64 72 2d 3e 73 74 72 69 6e 67 0a 20 20 kaddr->string.
ad30: 28 6c 65 74 2a 20 28 28 74 6c 73 6e 20 28 74 63 (let* ((tlsn (tc
ad40: 70 2d 6c 69 73 74 65 6e 20 70 6f 72 74 20 31 30 p-listen port 10
ad50: 30 30 30 20 23 66 29 29 20 3b 3b 20 28 74 63 70 000 #f)) ;; (tcp
ad60: 2d 6c 69 73 74 65 6e 20 54 43 50 50 4f 52 54 20 -listen TCPPORT
ad70: 5b 42 41 43 4b 4c 4f 47 20 5b 48 4f 53 54 5d 5d [BACKLOG [HOST]]
ad80: 29 0a 09 20 28 61 64 64 72 20 20 28 74 74 3a 67 ).. (addr (tt:g
ad90: 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 et-best-guess-ad
ada0: 64 72 65 73 73 20 28 67 65 74 2d 68 6f 73 74 2d dress (get-host-
adb0: 6e 61 6d 65 29 29 29 29 20 3b 3b 20 28 67 65 74 name)))) ;; (get
adc0: 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 73 73 -my-best-address
add0: 29 29 29 20 3b 3b 20 28 68 6f 73 74 69 6e 66 6f ))) ;; (hostinfo
ade0: 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 74 -addresses (host
adf0: 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 63 75 -information (cu
ae00: 72 72 65 6e 74 2d 68 6f 73 74 6e 61 6d 65 29 29 rrent-hostname))
ae10: 29 0a 20 20 20 20 28 74 74 2d 70 6f 72 74 2d 73 ). (tt-port-s
ae20: 65 74 21 20 20 20 20 20 20 75 63 6f 6e 6e 20 70 et! uconn p
ae30: 6f 72 74 29 0a 20 20 20 20 28 74 74 2d 68 6f 73 ort). (tt-hos
ae40: 74 2d 73 65 74 21 20 20 20 20 20 20 75 63 6f 6e t-set! ucon
ae50: 6e 20 61 64 64 72 29 0a 20 20 20 20 28 74 74 2d n addr). (tt-
ae60: 68 6f 73 74 2d 70 6f 72 74 2d 73 65 74 21 20 75 host-port-set! u
ae70: 63 6f 6e 6e 20 28 63 6f 6e 63 20 61 64 64 72 22 conn (conc addr"
ae80: 3a 22 70 6f 72 74 29 29 0a 20 20 20 20 28 74 74 :"port)). (tt
ae90: 2d 73 6f 63 6b 65 74 2d 73 65 74 21 20 20 20 20 -socket-set!
aea0: 75 63 6f 6e 6e 20 74 6c 73 6e 29 0a 20 20 20 20 uconn tlsn).
aeb0: 75 63 6f 6e 6e 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d uconn))..;;=====
aec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af00: 3d 0a 3b 3b 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d =.;; utils.;;===
af10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af50: 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 72 61 74 65 ===..;; Generate
af60: 20 61 20 75 6e 69 71 75 65 20 73 69 67 6e 61 74 a unique signat
af70: 75 72 65 20 66 6f 72 20 74 68 69 73 20 73 65 72 ure for this ser
af80: 76 65 72 0a 28 64 65 66 69 6e 65 20 28 74 74 3a ver.(define (tt:
af90: 6d 6b 2d 73 69 67 6e 61 74 75 72 65 20 61 72 65 mk-signature are
afa0: 61 70 61 74 68 29 0a 20 20 28 6d 65 73 73 61 67 apath). (messag
afb0: 65 2d 64 69 67 65 73 74 2d 73 74 72 69 6e 67 20 e-digest-string
afc0: 28 6d 64 35 2d 70 72 69 6d 69 74 69 76 65 29 20 (md5-primitive)
afd0: 0a 09 09 09 20 28 77 69 74 68 2d 6f 75 74 70 75 .... (with-outpu
afe0: 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 09 09 09 20 t-to-string....
aff0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 (lambda ()....
b000: 20 20 20 20 20 28 77 72 69 74 65 20 28 6c 69 73 (write (lis
b010: 74 20 61 72 65 61 70 61 74 68 0a 20 20 20 20 20 t areapath.
b020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b040: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 (current-pr
b050: 6f 63 65 73 73 2d 69 64 29 0a 09 09 09 09 09 20 ocess-id)......
b060: 20 28 61 72 67 76 29 29 29 29 29 29 29 0a 0a 0a (argv)))))))...
b070: 28 64 65 66 69 6e 65 20 28 74 74 3a 67 65 74 2d (define (tt:get-
b080: 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 best-guess-addre
b090: 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 ss hostname). (
b0a0: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 let ((res #f)).
b0b0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
b0c0: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 64 72 29 (lambda (adr)
b0d0: 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 . (if (not
b0e0: 20 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 2d (eq? (u8vector-
b0f0: 72 65 66 20 61 64 72 20 30 29 20 31 32 37 29 29 ref adr 0) 127))
b100: 0a 09 20 20 20 28 73 65 74 21 20 72 65 73 20 61 .. (set! res a
b110: 64 72 29 29 29 0a 20 20 20 20 20 3b 3b 20 4e 4f dr))). ;; NO
b120: 54 45 3a 20 54 68 69 73 20 63 61 6e 20 66 61 69 TE: This can fai
b130: 6c 20 77 68 65 6e 20 74 68 65 72 65 20 69 73 20 l when there is
b140: 6e 6f 20 6d 65 6e 74 69 6f 6e 20 6f 66 20 74 68 no mention of th
b150: 65 20 68 6f 73 74 20 69 6e 20 2f 65 74 63 2f 68 e host in /etc/h
b160: 6f 73 74 73 2e 20 46 49 58 4d 45 0a 20 20 20 20 osts. FIXME.
b170: 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 (vector->list (
b180: 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 hostinfo-address
b190: 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f es (hostname->ho
b1a0: 73 74 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 stinfo hostname)
b1b0: 29 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d ))). (string-
b1c0: 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 intersperse .
b1d0: 20 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 (map number->s
b1e0: 74 72 69 6e 67 0a 09 20 20 28 75 38 76 65 63 74 tring.. (u8vect
b1f0: 6f 72 2d 3e 6c 69 73 74 0a 09 20 20 20 28 69 66 or->list.. (if
b200: 20 72 65 73 20 72 65 73 20 28 68 6f 73 74 6e 61 res res (hostna
b210: 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 me->ip hostname)
b220: 29 29 29 20 22 2e 22 29 29 29 0a 0a 28 64 65 66 ))) ".")))..(def
b230: 69 6e 65 20 28 74 74 3a 67 65 74 2d 73 65 72 76 ine (tt:get-serv
b240: 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 61 74 info-dir areapat
b250: 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 70 61 h). (let* ((spa
b260: 74 68 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 th (conc areapat
b270: 68 22 2f 2e 73 65 72 76 69 6e 66 6f 22 29 29 29 h"/.servinfo")))
b280: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 . (if (not (f
b290: 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 70 61 74 ile-exists? spat
b2a0: 68 29 29 0a 09 28 63 72 65 61 74 65 2d 64 69 72 h))..(create-dir
b2b0: 65 63 74 6f 72 79 20 73 70 61 74 68 20 23 74 29 ectory spath #t)
b2c0: 29 0a 20 20 20 20 73 70 61 74 68 29 29 0a 0a 3b ). spath))..;
b2d0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
b2e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b310: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 6e 65 74 77 6f =======.;; netwo
b320: 72 6b 20 75 74 69 6c 69 74 69 65 73 0a 3b 3b 3d rk utilities.;;=
b330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b370: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 =====..;; NOTE:
b380: 4c 6f 6f 6b 20 61 74 20 61 64 64 72 65 73 73 2d Look at address-
b390: 69 6e 66 6f 20 65 67 67 20 61 73 20 61 6c 74 65 info egg as alte
b3a0: 72 6e 61 74 69 76 65 20 74 6f 20 73 6f 6d 65 20 rnative to some
b3b0: 6f 66 20 74 68 69 73 0a 0a 28 64 65 66 69 6e 65 of this..(define
b3c0: 20 28 72 61 74 65 2d 69 70 20 69 70 61 64 64 72 (rate-ip ipaddr
b3d0: 29 0a 20 20 28 72 65 67 65 78 2d 63 61 73 65 20 ). (regex-case
b3e0: 69 70 61 64 64 72 0a 20 20 20 20 28 20 22 5e 31 ipaddr. ( "^1
b3f0: 32 37 5c 5c 2e 2e 2a 22 20 5f 20 30 20 29 0a 20 27\\..*" _ 0 ).
b400: 20 20 20 28 20 22 5e 28 31 30 5c 5c 2e 30 7c 31 ( "^(10\\.0|1
b410: 39 32 5c 5c 2e 31 36 38 29 5c 5c 2e 2e 2a 22 20 92\\.168)\\..*"
b420: 5f 20 31 20 29 0a 20 20 20 20 28 20 65 6c 73 65 _ 1 ). ( else
b430: 20 32 20 29 20 29 29 0a 0a 3b 3b 20 43 68 61 6e 2 ) ))..;; Chan
b440: 67 65 20 74 68 69 73 20 74 6f 20 62 69 61 73 20 ge this to bias
b450: 66 6f 72 20 61 64 64 72 65 73 73 65 73 20 77 69 for addresses wi
b460: 74 68 20 61 20 72 65 61 73 6f 6e 61 62 6c 65 20 th a reasonable
b470: 62 72 6f 61 64 63 61 73 74 20 76 61 6c 75 65 3f broadcast value?
b480: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 69 70 2d .;;.(define (ip-
b490: 70 72 65 66 2d 6c 65 73 73 3f 20 61 20 62 29 0a pref-less? a b).
b4a0: 20 20 28 3e 20 28 72 61 74 65 2d 69 70 20 61 29 (> (rate-ip a)
b4b0: 20 28 72 61 74 65 2d 69 70 20 62 29 29 29 0a 0a (rate-ip b)))..
b4c0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6d 79 2d (define (get-my-
b4d0: 62 65 73 74 2d 61 64 64 72 65 73 73 29 0a 20 20 best-address).
b4e0: 28 6c 65 74 20 28 28 61 6c 6c 2d 6d 79 2d 61 64 (let ((all-my-ad
b4f0: 64 72 65 73 73 65 73 20 28 67 65 74 2d 61 6c 6c dresses (get-all
b500: 2d 69 70 73 29 29 29 0a 20 20 20 20 28 63 6f 6e -ips))). (con
b510: 64 0a 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 61 d. ((null? a
b520: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 ll-my-addresses)
b530: 0a 20 20 20 20 20 20 28 67 65 74 2d 68 6f 73 74 . (get-host
b540: 2d 6e 61 6d 65 29 29 20 20 20 20 20 20 20 20 20 -name))
b550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b570: 20 3b 3b 20 6e 6f 20 69 6e 74 65 72 66 61 63 65 ;; no interface
b580: 73 3f 0a 20 20 20 20 20 28 28 65 71 3f 20 28 6c s?. ((eq? (l
b590: 65 6e 67 74 68 20 61 6c 6c 2d 6d 79 2d 61 64 64 ength all-my-add
b5a0: 72 65 73 73 65 73 29 20 31 29 0a 20 20 20 20 20 resses) 1).
b5b0: 20 28 63 61 72 20 61 6c 6c 2d 6d 79 2d 61 64 64 (car all-my-add
b5c0: 72 65 73 73 65 73 29 29 20 20 20 20 20 20 20 20 resses))
b5d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
b5e0: 20 6f 6e 6c 79 20 6f 6e 65 20 74 6f 20 63 68 6f only one to cho
b5f0: 6f 73 65 20 66 72 6f 6d 2c 20 6a 75 73 74 20 67 ose from, just g
b600: 6f 20 77 69 74 68 20 69 74 0a 20 20 20 20 20 28 o with it. (
b610: 65 6c 73 65 0a 20 20 20 20 20 20 28 63 61 72 20 else. (car
b620: 28 73 6f 72 74 20 61 6c 6c 2d 6d 79 2d 61 64 64 (sort all-my-add
b630: 72 65 73 73 65 73 20 69 70 2d 70 72 65 66 2d 6c resses ip-pref-l
b640: 65 73 73 3f 29 29 29 29 29 29 0a 0a 28 64 65 66 ess?))))))..(def
b650: 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 ine (get-all-ips
b660: 2d 73 6f 72 74 65 64 29 0a 20 20 28 73 6f 72 74 -sorted). (sort
b670: 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 20 69 (get-all-ips) i
b680: 70 2d 70 72 65 66 2d 6c 65 73 73 3f 29 29 0a 0a p-pref-less?))..
b690: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 61 6c 6c (define (get-all
b6a0: 2d 69 70 73 29 0a 20 20 28 6d 61 70 20 61 64 64 -ips). (map add
b6b0: 72 65 73 73 2d 69 6e 66 6f 2d 68 6f 73 74 0a 20 ress-info-host.
b6c0: 20 20 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c (filter (l
b6d0: 61 6d 62 64 61 20 28 78 29 0a 09 09 20 28 65 71 ambda (x)... (eq
b6e0: 75 61 6c 3f 20 28 61 64 64 72 65 73 73 2d 69 6e ual? (address-in
b6f0: 66 6f 2d 74 79 70 65 20 78 29 20 22 74 63 70 22 fo-type x) "tcp"
b700: 29 29 0a 09 20 20 20 20 20 20 20 28 61 64 64 72 )).. (addr
b710: 65 73 73 2d 69 6e 66 6f 73 20 28 67 65 74 2d 68 ess-infos (get-h
b720: 6f 73 74 2d 6e 61 6d 65 29 29 29 29 29 0a 0a 3b ost-name)))))..;
b730: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
b740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b770: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4f 74 68 65 72 =======.;; Other
b780: 20 55 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d Utils.;;=======
b790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b7a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b7b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b7c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
b7d0: 0a 28 64 65 66 73 74 72 75 63 74 20 6a 73 74 61 .(defstruct jsta
b7e0: 74 73 0a 20 20 28 63 6f 75 6e 74 20 30 29 0a 20 ts. (count 0).
b7f0: 20 28 6a 63 6f 75 6e 74 20 28 6d 61 6b 65 2d 68 (jcount (make-h
b800: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 31 ash-table)) ;; 1
b810: 2e 64 62 20 3d 3e 20 6a 6f 75 72 6e 61 6c 5f 63 .db => journal_c
b820: 6f 75 6e 74 0a 20 20 29 0a 0a 3b 3b 20 74 69 6d ount. )..;; tim
b830: 65 62 6c 6b 20 3d 3e 20 6a 73 74 61 74 73 0a 28 eblk => jstats.(
b840: 64 65 66 69 6e 65 20 2a 6a 6f 75 72 6e 61 6c 2d define *journal-
b850: 73 74 61 74 73 2a 20 23 66 29 20 3b 3b 20 28 6d stats* #f) ;; (m
b860: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
b870: 0a 0a 3b 3b 20 6d 6f 6e 74 65 2d 63 61 72 6c 6f ..;; monte-carlo
b880: 2d 65 73 71 75 65 20 72 61 6e 64 6f 6d 20 73 61 -esque random sa
b890: 6d 70 6c 69 6e 67 20 6f 66 20 6a 6f 75 72 6e 61 mpling of journa
b8a0: 6c 20 66 69 6c 65 73 0a 3b 3b 20 66 6f 72 20 61 l files.;; for a
b8b0: 6c 6c 20 74 68 65 20 66 69 6c 65 73 3a 0a 3b 3b ll the files:.;;
b8c0: 20 20 20 69 66 20 2e 6a 6f 75 72 6e 61 6c 0a 3b if .journal.;
b8d0: 3b 20 20 20 20 20 20 75 70 64 61 74 65 20 73 74 ; update st
b8e0: 61 74 73 20 2b 31 20 2b 31 0a 3b 3b 20 20 20 20 ats +1 +1.;;
b8f0: 20 20 75 70 64 61 74 65 20 73 74 61 74 73 20 2b update stats +
b900: 31 20 20 30 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 1 0.;;.(define
b910: 28 74 74 3a 77 72 69 74 65 2d 6c 6f 61 64 2d 74 (tt:write-load-t
b920: 72 61 63 6b 69 6e 67 20 64 62 64 69 72 29 0a 20 racking dbdir).
b930: 20 28 6c 65 74 2a 20 28 28 63 73 20 20 20 20 28 (let* ((cs (
b940: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
b950: 29 0a 09 20 28 6b 65 79 20 20 20 28 69 6e 65 78 ).. (key (inex
b960: 61 63 74 2d 3e 65 78 61 63 74 20 28 71 75 6f 74 act->exact (quot
b970: 69 65 6e 74 20 63 73 20 31 30 29 29 29 0a 09 20 ient cs 10)))..
b980: 28 6f 6c 64 20 20 20 28 2d 20 6b 65 79 20 35 29 (old (- key 5)
b990: 29 20 3b 3b 20 34 20 78 20 31 30 20 73 65 63 6f ) ;; 4 x 10 seco
b9a0: 6e 64 73 20 61 67 6f 0a 09 20 28 6a 73 74 61 74 nds ago.. (jstat
b9b0: 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 (if (hash-table
b9c0: 2d 65 78 69 73 74 73 3f 20 2a 6a 6f 75 72 6e 61 -exists? *journa
b9d0: 6c 2d 73 74 61 74 73 2a 20 6b 65 79 29 0a 09 09 l-stats* key)...
b9e0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
b9f0: 72 65 66 20 2a 6a 6f 75 72 6e 61 6c 2d 73 74 61 ref *journal-sta
ba00: 74 73 2a 20 6b 65 79 20 29 0a 09 09 20 20 20 20 ts* key )...
ba10: 28 6c 65 74 20 28 28 6e 65 77 20 28 6d 61 6b 65 (let ((new (make
ba20: 2d 6a 73 74 61 74 73 29 29 29 0a 09 09 20 20 20 -jstats)))...
ba30: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
ba40: 65 74 21 20 2a 6a 6f 75 72 6e 61 6c 2d 73 74 61 et! *journal-sta
ba50: 74 73 2a 20 6b 65 79 20 6e 65 77 29 0a 09 09 20 ts* key new)...
ba60: 20 20 20 20 20 6e 65 77 29 29 29 29 0a 20 20 20 new)))).
ba70: 20 3b 3b 20 63 6c 65 61 72 20 6f 75 74 20 6f 6c ;; clear out ol
ba80: 64 20 72 65 63 6f 72 64 73 0a 20 20 20 20 28 66 d records. (f
ba90: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
baa0: 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 20 20 20 mbda (key).
bab0: 20 20 28 69 66 20 28 3c 20 6b 65 79 20 6f 6c 64 (if (< key old
bac0: 29 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ).. (hash-tabl
bad0: 65 2d 64 65 6c 65 74 65 21 20 2a 6a 6f 75 72 6e e-delete! *journ
bae0: 61 6c 2d 73 74 61 74 73 2a 20 6b 65 79 29 29 29 al-stats* key)))
baf0: 0a 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c . (hash-tabl
bb00: 65 2d 6b 65 79 73 20 2a 6a 6f 75 72 6e 61 6c 2d e-keys *journal-
bb10: 73 74 61 74 73 2a 29 29 0a 0a 20 20 20 20 3b 3b stats*)).. ;;
bb20: 20 69 6e 63 72 65 6d 65 6e 74 20 6f 75 72 20 63 increment our c
bb30: 6f 75 6e 74 20 6f 66 20 6f 62 73 65 72 76 61 74 ount of observat
bb40: 69 6f 6e 73 0a 20 20 20 20 28 6a 73 74 61 74 73 ions. (jstats
bb50: 2d 63 6f 75 6e 74 2d 73 65 74 21 20 6a 73 74 61 -count-set! jsta
bb60: 74 20 28 2b 20 28 6a 73 74 61 74 73 2d 63 6f 75 t (+ (jstats-cou
bb70: 6e 74 20 6a 73 74 61 74 29 20 31 29 29 0a 20 20 nt jstat) 1)).
bb80: 20 20 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 66 69 . ;; now fi
bb90: 6e 64 20 61 6e 64 20 69 6e 63 72 65 6d 65 6e 74 nd and increment
bba0: 20 6a 6f 75 72 6e 61 6c 20 66 69 6c 65 20 63 6f journal file co
bbb0: 75 6e 74 73 0a 20 20 20 20 28 64 69 72 65 63 74 unts. (direct
bbc0: 6f 72 79 2d 66 6f 6c 64 0a 20 20 20 20 20 28 6c ory-fold. (l
bbd0: 61 6d 62 64 61 20 28 66 6e 61 6d 65 20 72 65 73 ambda (fname res
bbe0: 29 0a 20 20 20 20 20 20 20 3b 3b 20 69 73 20 69 ). ;; is i
bbf0: 74 20 61 20 6a 6f 75 72 6e 61 6c 20 66 69 6c 65 t a journal file
bc00: 3f 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 ?. (let ((
bc10: 70 61 72 74 73 20 28 73 74 72 69 6e 67 2d 6d 61 parts (string-ma
bc20: 74 63 68 20 22 5e 28 2e 2a 5c 5c 2e 64 62 29 2d tch "^(.*\\.db)-
bc30: 6a 6f 75 72 6e 61 6c 2e 2a 22 20 66 6e 61 6d 65 journal.*" fname
bc40: 29 29 29 0a 09 20 28 6d 61 74 63 68 20 70 61 72 ))).. (match par
bc50: 74 73 0a 09 20 20 20 28 28 5f 20 64 62 66 6e 61 ts.. ((_ dbfna
bc60: 6d 65 29 0a 09 20 20 20 20 28 68 61 73 68 2d 74 me).. (hash-t
bc70: 61 62 6c 65 2d 73 65 74 21 20 28 6a 73 74 61 74 able-set! (jstat
bc80: 73 2d 6a 63 6f 75 6e 74 20 6a 73 74 61 74 29 20 s-jcount jstat)
bc90: 64 62 66 6e 61 6d 65 0a 09 09 09 20 20 20 20 20 dbfname....
bca0: 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (+ (hash-table-r
bcb0: 65 66 2f 64 65 66 61 75 6c 74 20 28 6a 73 74 61 ef/default (jsta
bcc0: 74 73 2d 6a 63 6f 75 6e 74 20 6a 73 74 61 74 29 ts-jcount jstat)
bcd0: 20 64 62 66 6e 61 6d 65 20 30 29 20 31 29 0a 09 dbfname 0) 1)..
bce0: 09 09 20 20 20 20 20 29 29 0a 09 20 20 20 28 65 .. )).. (e
bcf0: 6c 73 65 20 23 66 29 0a 09 20 20 20 29 29 29 0a lse #f).. ))).
bd00: 20 20 20 20 20 27 28 29 0a 20 20 20 20 20 64 62 '(). db
bd10: 64 69 72 20 0a 20 20 20 20 20 29 29 29 0a 0a 28 dir . )))..(
bd20: 64 65 66 69 6e 65 20 2a 6a 6f 75 72 6e 61 6c 2d define *journal-
bd30: 73 74 61 74 73 2d 6d 75 74 65 78 2a 20 28 6d 61 stats-mutex* (ma
bd40: 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 28 64 65 66 ke-mutex))..(def
bd50: 69 6e 65 20 28 74 74 3a 6a 6f 75 72 6e 61 6c 2d ine (tt:journal-
bd60: 73 74 61 74 73 2d 72 75 6e 20 64 62 64 69 72 29 stats-run dbdir)
bd70: 0a 20 20 28 69 66 20 28 6e 6f 74 20 2a 6a 6f 75 . (if (not *jou
bd80: 72 6e 61 6c 2d 73 74 61 74 73 2a 29 28 73 65 74 rnal-stats*)(set
bd90: 21 20 2a 6a 6f 75 72 6e 61 6c 2d 73 74 61 74 73 ! *journal-stats
bda0: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
bdb0: 6c 65 29 29 29 0a 20 20 28 6c 65 74 20 6c 6f 6f le))). (let loo
bdc0: 70 20 28 29 0a 20 20 20 20 28 6d 75 74 65 78 2d p (). (mutex-
bdd0: 6c 6f 63 6b 21 20 2a 6a 6f 75 72 6e 61 6c 2d 73 lock! *journal-s
bde0: 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a 20 20 20 tats-mutex*).
bdf0: 20 28 74 74 3a 77 72 69 74 65 2d 6c 6f 61 64 2d (tt:write-load-
be00: 74 72 61 63 6b 69 6e 67 20 64 62 64 69 72 29 0a tracking dbdir).
be10: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
be20: 6b 21 20 2a 6a 6f 75 72 6e 61 6c 2d 73 74 61 74 k! *journal-stat
be30: 73 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 74 s-mutex*). (t
be40: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 hread-sleep! (/
be50: 28 72 61 6e 64 6f 6d 20 31 30 30 30 29 20 31 30 (random 1000) 10
be60: 30 2e 30 29 29 0a 20 20 20 20 28 6c 6f 6f 70 29 0.0)). (loop)
be70: 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 68 69 73 ))..;; call this
be80: 20 74 6f 20 73 74 61 72 74 20 61 20 74 68 72 65 to start a thre
be90: 61 64 20 74 68 61 74 20 69 73 20 6b 65 65 70 69 ad that is keepi
bea0: 6e 67 20 74 68 65 20 6a 6f 75 72 6e 61 6c 2d 73 ng the journal-s
beb0: 74 61 74 73 20 75 70 20 74 6f 20 64 61 74 65 2e tats up to date.
bec0: 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 73 74 61 .(define (tt:sta
bed0: 72 74 2d 73 74 61 74 73 20 64 62 64 69 72 29 0a rt-stats dbdir).
bee0: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
bef0: 0a 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 . (make-thread
bf00: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 28 . (lambda ()(
bf10: 74 74 3a 6a 6f 75 72 6e 61 6c 2d 73 74 61 74 73 tt:journal-stats
bf20: 2d 72 75 6e 20 64 62 64 69 72 29 29 20 22 4a 6f -run dbdir)) "Jo
bf30: 75 72 6e 61 6c 20 73 74 61 74 73 20 63 6f 6c 6c urnal stats coll
bf40: 65 63 74 69 6f 6e 20 74 68 72 65 61 64 22 29 29 ection thread"))
bf50: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 67 )..(define (tt:g
bf60: 65 74 2d 6a 6f 75 72 6e 61 6c 2d 73 74 61 74 73 et-journal-stats
bf70: 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 73 75 ). (let* ((resu
bf80: 6c 74 20 20 20 20 28 6d 61 6b 65 2d 6a 73 74 61 lt (make-jsta
bf90: 74 73 29 29 0a 09 20 28 68 69 74 63 6f 75 6e 74 ts)).. (hitcount
bfa0: 73 20 28 6a 73 74 61 74 73 2d 6a 63 6f 75 6e 74 s (jstats-jcount
bfb0: 20 72 65 73 75 6c 74 29 29 29 0a 20 20 20 20 28 result))). (
bfc0: 69 66 20 2a 6a 6f 75 72 6e 61 6c 2d 73 74 61 74 if *journal-stat
bfd0: 73 2a 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 6d s*..(begin.. (m
bfe0: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 6a 6f 75 72 utex-lock! *jour
bff0: 6e 61 6c 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a nal-stats-mutex*
c000: 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ).. (hash-table
c010: 2d 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 2a 6a -for-each.. *j
c020: 6f 75 72 6e 61 6c 2d 73 74 61 74 73 2a 0a 09 20 ournal-stats*..
c030: 20 20 28 6c 61 6d 62 64 61 20 28 6b 20 76 29 20 (lambda (k v)
c040: 3b 3b 20 6b 65 79 20 6a 73 74 61 74 73 0a 09 20 ;; key jstats..
c050: 20 20 20 20 28 6c 65 74 2a 20 28 28 63 6f 75 6e (let* ((coun
c060: 74 20 20 28 6a 73 74 61 74 73 2d 63 6f 75 6e 74 t (jstats-count
c070: 20 76 29 29 0a 09 09 20 20 20 20 28 6a 63 6f 75 v))... (jcou
c080: 6e 74 20 28 6a 73 74 61 74 73 2d 6a 63 6f 75 6e nt (jstats-jcoun
c090: 74 20 76 29 29 29 20 3b 3b 20 64 62 66 6e 61 6d t v))) ;; dbfnam
c0a0: 65 20 3d 3e 20 68 69 74 20 63 6f 75 6e 74 0a 09 e => hit count..
c0b0: 20 20 20 20 20 20 20 28 6a 73 74 61 74 73 2d 63 (jstats-c
c0c0: 6f 75 6e 74 2d 73 65 74 21 20 72 65 73 75 6c 74 ount-set! result
c0d0: 0a 09 09 09 09 20 20 28 2b 20 28 6a 73 74 61 74 ..... (+ (jstat
c0e0: 73 2d 63 6f 75 6e 74 20 72 65 73 75 6c 74 29 0a s-count result).
c0f0: 09 09 09 09 20 20 20 20 20 28 6a 73 74 61 74 73 .... (jstats
c100: 2d 63 6f 75 6e 74 20 76 29 29 29 0a 09 20 20 20 -count v)))..
c110: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
c120: 66 6f 72 2d 65 61 63 68 0a 09 09 6a 63 6f 75 6e for-each...jcoun
c130: 74 0a 09 09 28 6c 61 6d 62 64 61 20 28 64 62 66 t...(lambda (dbf
c140: 6e 61 6d 65 20 68 69 74 2d 63 6f 75 6e 74 29 0a name hit-count).
c150: 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
c160: 73 65 74 21 20 68 69 74 63 6f 75 6e 74 73 20 64 set! hitcounts d
c170: 62 66 6e 61 6d 65 0a 09 09 09 09 20 20 20 28 2b bfname..... (+
c180: 20 68 69 74 2d 63 6f 75 6e 74 0a 09 09 09 09 20 hit-count.....
c190: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
c1a0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 69 74 -ref/default hit
c1b0: 63 6f 75 6e 74 73 20 64 62 66 6e 61 6d 65 20 30 counts dbfname 0
c1c0: 29 29 29 29 29 29 29 29 0a 09 20 20 28 6d 75 74 )))))))).. (mut
c1d0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 6a 6f 75 72 ex-unlock! *jour
c1e0: 6e 61 6c 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a nal-stats-mutex*
c1f0: 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ))..(debug:print
c200: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
c210: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 2a 6a 6f port* "INFO: *jo
c220: 75 72 6e 61 6c 2d 73 74 61 74 73 2a 20 6e 6f 74 urnal-stats* not
c230: 20 73 65 74 2e 22 29 29 0a 20 20 20 20 3b 3b 20 set.")). ;;
c240: 63 6f 6e 76 65 72 74 20 74 6f 20 6e 6f 72 6d 61 convert to norma
c250: 6c 69 7a 65 64 20 61 6c 69 73 74 0a 20 20 20 20 lized alist.
c260: 28 6c 65 74 20 28 28 74 6f 74 20 20 28 6d 69 6e (let ((tot (min
c270: 20 28 6a 73 74 61 74 73 2d 63 6f 75 6e 74 20 72 (jstats-count r
c280: 65 73 75 6c 74 29 20 31 29 29 20 3b 3b 20 61 76 esult) 1)) ;; av
c290: 6f 69 64 20 64 69 76 69 64 65 20 62 79 20 7a 65 oid divide by ze
c2a0: 72 6f 0a 09 20 20 28 68 69 74 73 20 28 6a 73 74 ro.. (hits (jst
c2b0: 61 74 73 2d 6a 63 6f 75 6e 74 20 72 65 73 75 6c ats-jcount resul
c2c0: 74 29 29 29 20 3b 3b 20 31 2e 64 62 20 3d 3e 20 t))) ;; 1.db =>
c2d0: 63 6f 75 6e 74 0a 20 20 20 20 20 20 28 68 61 73 count. (has
c2e0: 68 2d 74 61 62 6c 65 2d 6d 61 70 0a 20 20 20 20 h-table-map.
c2f0: 20 20 20 68 69 74 73 0a 20 20 20 20 20 20 20 28 hits. (
c300: 6c 61 6d 62 64 61 20 28 66 6e 61 6d 65 20 68 69 lambda (fname hi
c310: 74 63 6f 75 6e 74 29 0a 09 20 28 63 6f 6e 73 20 tcount).. (cons
c320: 66 6e 61 6d 65 20 28 2f 20 68 69 74 63 6f 75 6e fname (/ hitcoun
c330: 74 20 74 6f 74 29 29 29 29 29 0a 20 20 20 20 29 t tot))))). )
c340: 29 0a 0a 3b 3b 20 6d 65 67 61 74 65 73 74 3e 20 )..;; megatest>
c350: 28 69 6d 70 6f 72 74 20 74 63 70 2d 74 72 61 6e (import tcp-tran
c360: 73 70 6f 72 74 6d 6f 64 29 0a 3b 3b 20 6d 65 67 sportmod).;; meg
c370: 61 74 65 73 74 3e 20 28 74 74 3a 77 72 69 74 65 atest> (tt:write
c380: 2d 6c 6f 61 64 2d 74 72 61 63 6b 69 6e 67 20 22 -load-tracking "
c390: 2e 6d 74 64 62 22 29 0a 3b 3b 20 6d 65 67 61 74 .mtdb").;; megat
c3a0: 65 73 74 3e 20 28 68 61 73 68 2d 74 61 62 6c 65 est> (hash-table
c3b0: 2d 6b 65 79 73 20 2a 6a 6f 75 72 6e 61 6c 2d 73 -keys *journal-s
c3c0: 74 61 74 73 2a 29 0a 3b 3b 20 28 31 37 32 30 36 tats*).;; (17206
c3d0: 30 32 39 37 29 0a 3b 3b 20 6d 65 67 61 74 65 73 0297).;; megates
c3e0: 74 3e 20 28 6a 73 74 61 74 73 2d 3e 61 6c 69 73 t> (jstats->alis
c3f0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
c400: 66 20 2a 6a 6f 75 72 6e 61 6c 2d 73 74 61 74 73 f *journal-stats
c410: 2a 20 31 37 32 30 36 30 32 39 37 29 29 0a 3b 3b * 172060297)).;;
c420: 20 28 28 63 6f 75 6e 74 20 2e 20 31 29 20 28 6a ((count . 1) (j
c430: 63 6f 75 6e 74 20 2e 20 23 3c 68 61 73 68 2d 74 count . #<hash-t
c440: 61 62 6c 65 20 28 31 29 3e 29 29 0a 3b 3b 20 6d able (1)>)).;; m
c450: 65 67 61 74 65 73 74 3e 20 28 6a 73 74 61 74 73 egatest> (jstats
c460: 2d 6a 63 6f 75 6e 74 20 28 68 61 73 68 2d 74 61 -jcount (hash-ta
c470: 62 6c 65 2d 72 65 66 20 2a 6a 6f 75 72 6e 61 6c ble-ref *journal
c480: 2d 73 74 61 74 73 2a 20 31 37 32 30 36 30 32 39 -stats* 17206029
c490: 37 29 29 0a 3b 3b 20 23 3c 68 61 73 68 2d 74 61 7)).;; #<hash-ta
c4a0: 62 6c 65 20 28 31 29 3e 0a 3b 3b 20 6d 65 67 61 ble (1)>.;; mega
c4b0: 74 65 73 74 3e 20 28 68 61 73 68 2d 74 61 62 6c test> (hash-tabl
c4c0: 65 2d 3e 61 6c 69 73 74 20 28 6a 73 74 61 74 73 e->alist (jstats
c4d0: 2d 6a 63 6f 75 6e 74 20 28 68 61 73 68 2d 74 61 -jcount (hash-ta
c4e0: 62 6c 65 2d 72 65 66 20 2a 6a 6f 75 72 6e 61 6c ble-ref *journal
c4f0: 2d 73 74 61 74 73 2a 20 31 37 32 30 36 30 32 39 -stats* 17206029
c500: 37 29 29 29 0a 3b 3b 20 28 28 22 31 2e 64 62 22 7))).;; (("1.db"
c510: 20 2e 20 34 29 29 0a 0a 29 0a . 4))..).