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 20 20 28 69 6d 70 6f 72 74 20 73 63 68 65 6d . (import schem
0470: 65 0a 09 20 20 28 70 72 65 66 69 78 20 73 71 6c e.. (prefix sql
0480: 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 0a 09 ite3 sqlite3:)..
0490: 20 20 63 68 69 63 6b 65 6e 0a 09 20 20 64 61 74 chicken.. dat
04a0: 61 2d 73 74 72 75 63 74 75 72 65 73 0a 0a 09 20 a-structures...
04b0: 20 61 64 64 72 65 73 73 2d 69 6e 66 6f 0a 09 20 address-info..
04c0: 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 directory-utils
04d0: 0a 09 20 20 65 78 74 72 61 73 0a 09 20 20 66 69 .. extras.. fi
04e0: 6c 65 73 0a 09 20 20 68 6f 73 74 69 6e 66 6f 0a les.. hostinfo.
04f0: 09 20 20 6d 61 74 63 68 61 62 6c 65 0a 09 20 20 . matchable..
0500: 6d 64 35 0a 09 20 20 6d 65 73 73 61 67 65 2d 64 md5.. message-d
0510: 69 67 65 73 74 0a 09 20 20 70 6f 72 74 73 0a 09 igest.. ports..
0520: 20 20 70 6f 73 69 78 0a 09 20 20 72 65 67 65 78 posix.. regex
0530: 0a 09 20 20 72 65 67 65 78 2d 63 61 73 65 0a 09 .. regex-case..
0540: 20 20 73 31 31 6e 0a 09 20 20 73 72 66 69 2d 31 s11n.. srfi-1
0550: 0a 09 20 20 73 72 66 69 2d 31 38 0a 09 20 20 73 .. srfi-18.. s
0560: 72 66 69 2d 34 0a 09 20 20 73 72 66 69 2d 36 39 rfi-4.. srfi-69
0570: 0a 09 20 20 73 74 61 63 6b 0a 09 20 20 74 79 70 .. stack.. typ
0580: 65 64 2d 72 65 63 6f 72 64 73 0a 09 20 20 74 63 ed-records.. tc
0590: 70 2d 73 65 72 76 65 72 0a 09 20 20 74 63 70 0a p-server.. tcp.
05a0: 09 20 20 0a 09 20 20 64 65 62 75 67 70 72 69 6e . .. debugprin
05b0: 74 0a 09 20 20 63 6f 6d 6d 6f 6e 6d 6f 64 0a 09 t.. commonmod..
05c0: 20 20 64 62 66 69 6c 65 0a 09 20 20 64 62 6d 6f dbfile.. dbmo
05d0: 64 0a 09 20 20 70 6f 72 74 6c 6f 67 67 65 72 0a d.. portlogger.
05e0: 09 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .)..;;==========
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
0630: 63 6c 69 65 6e 74 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d client.;;=======
0640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
0680: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 6b 65 65 70 .;; (define keep
0690: 2d 61 67 65 2d 70 61 72 61 6d 20 28 6d 61 6b 65 -age-param (make
06a0: 2d 70 61 72 61 6d 65 74 65 72 20 31 30 29 29 20 -parameter 10))
06b0: 3b 3b 20 71 69 66 20 66 69 6c 65 20 61 67 65 2c ;; qif file age,
06c0: 20 69 66 20 6f 76 65 72 20 6d 6f 76 65 20 74 6f if over move to
06d0: 20 61 74 74 69 63 0a 0a 3b 3b 20 55 73 65 64 20 attic..;; Used
06e0: 4f 4e 4c 59 20 66 6f 72 20 63 6c 69 65 6e 74 0a ONLY for client.
06f0: 3b 3b 0a 28 64 65 66 73 74 72 75 63 74 20 74 74 ;;.(defstruct tt
0700: 2d 63 6f 6e 6e 0a 20 20 68 6f 73 74 0a 20 20 70 -conn. host. p
0710: 6f 72 74 0a 20 20 68 6f 73 74 2d 70 6f 72 74 0a ort. host-port.
0720: 20 20 64 62 66 6e 61 6d 65 0a 20 20 73 65 72 76 dbfname. serv
0730: 65 72 2d 69 64 0a 20 20 73 65 72 76 65 72 2d 73 er-id. server-s
0740: 74 61 72 74 0a 20 20 73 65 72 76 69 6e 66 2d 66 tart. servinf-f
0750: 69 6c 65 0a 20 20 70 69 64 0a 29 0a 0a 3b 3b 20 ile. pid.)..;;
0760: 55 73 65 64 20 66 6f 72 20 42 4f 54 48 20 63 6c Used for BOTH cl
0770: 69 65 6e 74 73 20 61 6e 64 20 73 65 72 76 65 72 ients and server
0780: 73 0a 28 64 65 66 73 74 72 75 63 74 20 74 74 0a s.(defstruct tt.
0790: 20 20 3b 3b 20 63 6c 69 65 6e 74 20 72 65 6c 61 ;; client rela
07a0: 74 65 64 0a 20 20 28 63 6f 6e 6e 73 20 28 6d 61 ted. (conns (ma
07b0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
07c0: 3b 3b 20 64 62 66 6e 61 6d 65 20 2d 3e 20 63 6f ;; dbfname -> co
07d0: 6e 6e 0a 0a 20 20 3b 3b 20 73 65 72 76 65 72 20 nn.. ;; server
07e0: 72 65 6c 61 74 65 64 0a 20 20 28 73 74 61 74 65 related. (state
07f0: 20 20 20 20 20 20 20 20 27 73 74 61 72 74 69 6e 'startin
0800: 67 29 0a 20 20 28 61 72 65 61 70 61 74 68 20 20 g). (areapath
0810: 20 20 20 23 66 29 0a 20 20 28 68 6f 73 74 20 20 #f). (host
0820: 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 70 6f #f). (po
0830: 72 74 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 rt #f).
0840: 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 23 (conn #
0850: 66 29 0a 20 20 28 63 6c 65 61 6e 75 70 2d 70 72 f). (cleanup-pr
0860: 6f 63 20 23 66 29 0a 20 20 28 68 61 6e 64 6c 65 oc #f). (handle
0870: 72 20 20 20 20 20 20 23 66 29 20 3b 3b 20 72 65 r #f) ;; re
0880: 63 65 69 76 65 73 20 64 61 74 61 20 61 6e 64 20 ceives data and
0890: 72 65 73 70 6f 6e 64 73 0a 20 20 28 73 6f 63 6b responds. (sock
08a0: 65 74 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 et #f). (
08b0: 74 68 72 65 61 64 20 20 20 20 20 20 20 23 66 29 thread #f)
08c0: 0a 20 20 28 68 6f 73 74 2d 70 6f 72 74 20 20 20 . (host-port
08d0: 20 23 66 29 0a 20 20 28 63 6d 64 2d 74 68 72 65 #f). (cmd-thre
08e0: 61 64 20 20 20 23 66 29 0a 20 20 28 72 6f 2d 6d ad #f). (ro-m
08f0: 6f 64 65 20 20 20 20 20 20 23 66 29 0a 20 20 28 ode #f). (
0900: 72 6f 2d 6d 6f 64 65 2d 63 68 65 63 6b 65 64 20 ro-mode-checked
0910: 23 66 29 0a 20 20 28 6c 61 73 74 2d 61 63 63 65 #f). (last-acce
0920: 73 73 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ss (current-sec
0930: 6f 6e 64 73 29 29 0a 20 20 28 73 65 72 76 69 6e onds)). (servin
0940: 66 2d 66 69 6c 65 20 23 66 29 0a 20 20 28 6c 61 f-file #f). (la
0950: 73 74 2d 73 65 72 76 2d 73 74 61 72 74 20 30 29 st-serv-start 0)
0960: 0a 20 20 29 0a 0a 3b 3b 20 70 61 72 61 6d 65 74 . )..;; paramet
0970: 65 72 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 74 ers.;;.(define t
0980: 74 2d 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 t-server-timeout
0990: 2d 70 61 72 61 6d 20 28 6d 61 6b 65 2d 70 61 72 -param (make-par
09a0: 61 6d 65 74 65 72 20 36 30 30 29 29 0a 0a 3b 3b ameter 600))..;;
09b0: 20 6d 61 6b 65 20 74 74 64 61 74 20 76 69 73 69 make ttdat visi
09c0: 62 6c 65 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 ble.(define *ser
09d0: 76 65 72 2d 69 6e 66 6f 2a 20 23 66 29 0a 0a 28 ver-info* #f)..(
09e0: 64 65 66 69 6e 65 20 28 74 74 3a 6d 61 6b 65 2d define (tt:make-
09f0: 72 65 6d 6f 74 65 20 61 72 65 61 70 61 74 68 29 remote areapath)
0a00: 0a 20 20 28 6d 61 6b 65 2d 74 74 20 61 72 65 61 . (make-tt area
0a10: 70 61 74 68 3a 20 61 72 65 61 70 61 74 68 29 29 path: areapath))
0a20: 0a 0a 3b 3b 20 31 20 2e 2e 2e 20 6f 72 20 23 66 ..;; 1 ... or #f
0a30: 0a 3b 3b 20 61 6e 64 20 63 68 65 63 6b 20 74 68 .;; and check th
0a40: 61 74 20 64 62 66 6e 61 6d 65 20 6d 61 74 63 68 at dbfname match
0a50: 65 73 2e 20 46 49 58 4d 45 3a 20 74 68 65 20 70 es. FIXME: the p
0a60: 72 6f 70 61 67 61 74 69 6f 6e 20 6f 66 20 64 62 ropagation of db
0a70: 66 6e 61 6d 65 20 61 6e 64 20 72 75 6e 2d 69 64 fname and run-id
0a80: 0a 3b 3b 20 6d 69 67 68 74 20 6e 6f 74 20 6d 61 .;; might not ma
0a90: 6b 65 20 74 68 65 20 62 65 73 74 20 73 65 6e 73 ke the best sens
0aa0: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 74 e.;;.(define (tt
0ab0: 3a 76 61 6c 69 64 2d 72 75 6e 2d 69 64 20 72 75 :valid-run-id ru
0ac0: 6e 2d 69 64 20 64 62 66 6e 61 6d 65 29 0a 20 20 n-id dbfname).
0ad0: 28 61 6e 64 20 28 6f 72 20 28 6e 75 6d 62 65 72 (and (or (number
0ae0: 3f 20 72 75 6e 2d 69 64 29 0a 09 20 20 20 28 6e ? run-id).. (n
0af0: 6f 74 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 ot run-id)).
0b00: 20 20 20 28 65 71 75 61 6c 3f 20 28 64 62 66 69 (equal? (dbfi
0b10: 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 6e 61 le:run-id->dbfna
0b20: 6d 65 20 72 75 6e 2d 69 64 29 20 64 62 66 6e 61 me run-id) dbfna
0b30: 6d 65 29 29 29 0a 0a 28 74 63 70 2d 62 75 66 66 me)))..(tcp-buff
0b40: 65 72 2d 73 69 7a 65 20 32 30 34 38 29 0a 3b 3b er-size 2048).;;
0b50: 20 28 6d 61 78 2d 63 6f 6e 6e 65 63 74 69 6f 6e (max-connection
0b60: 73 20 34 30 39 36 29 20 0a 0a 3b 3b 20 64 6f 20 s 4096) ..;; do
0b70: 61 6c 6c 20 74 68 65 20 62 75 73 79 20 77 6f 72 all the busy wor
0b80: 6b 20 6f 66 20 66 69 6e 64 69 6e 67 20 61 6e 64 k of finding and
0b90: 20 73 65 74 74 69 6e 67 20 75 70 20 63 6f 6e 6e setting up conn
0ba0: 20 66 6f 72 0a 3b 3b 20 63 6f 6e 6e 65 63 74 69 for.;; connecti
0bb0: 6e 67 20 74 6f 20 61 20 73 65 72 76 65 72 0a 3b ng to a server.;
0bc0: 3b 20 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 63 ; .(define (tt:c
0bd0: 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f lient-connect-to
0be0: 2d 73 65 72 76 65 72 20 74 74 64 61 74 20 64 62 -server ttdat db
0bf0: 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 fname run-id tes
0c00: 74 73 75 69 74 65 29 0a 20 20 28 61 73 73 65 72 tsuite). (asser
0c10: 74 20 28 74 74 3a 76 61 6c 69 64 2d 72 75 6e 2d t (tt:valid-run-
0c20: 69 64 20 72 75 6e 2d 69 64 20 64 62 66 6e 61 6d id run-id dbfnam
0c30: 65 29 20 22 46 41 54 41 4c 3a 20 69 6e 76 61 6c e) "FATAL: inval
0c40: 69 64 20 72 75 6e 2d 69 64 20 22 72 75 6e 2d 69 id run-id "run-i
0c50: 64 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e d). (debug:prin
0c60: 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
0c70: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 74 3a t-log-port* "tt:
0c80: 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 client-connect-t
0c90: 6f 2d 73 65 72 76 65 72 20 22 20 64 62 66 6e 61 o-server " dbfna
0ca0: 6d 65 20 22 20 22 20 72 75 6e 2d 69 64 29 0a 20 me " " run-id).
0cb0: 20 28 6c 65 74 2a 20 28 28 63 6f 6e 6e 20 28 68 (let* ((conn (h
0cc0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
0cd0: 66 61 75 6c 74 20 28 74 74 2d 63 6f 6e 6e 73 20 fault (tt-conns
0ce0: 74 74 64 61 74 29 20 64 62 66 6e 61 6d 65 20 23 ttdat) dbfname #
0cf0: 66 29 29 0a 09 20 28 73 65 72 76 65 72 2d 73 74 f)).. (server-st
0d00: 61 72 74 2d 70 72 6f 63 20 28 6c 61 6d 62 64 61 art-proc (lambda
0d10: 20 28 29 0a 09 09 09 20 20 20 20 20 20 0a 09 09 ().... ...
0d20: 09 20 20 20 20 20 20 28 74 74 3a 73 65 72 76 65 . (tt:serve
0d30: 72 2d 70 72 6f 63 65 73 73 2d 72 75 6e 0a 09 09 r-process-run...
0d40: 09 20 20 20 20 20 20 20 28 74 74 2d 61 72 65 61 . (tt-area
0d50: 70 61 74 68 20 74 74 64 61 74 29 0a 09 09 09 20 path ttdat)....
0d60: 20 20 20 20 20 20 74 65 73 74 73 75 69 74 65 20 testsuite
0d70: 3b 3b 20 28 64 62 66 69 6c 65 3a 74 65 73 74 73 ;; (dbfile:tests
0d80: 75 69 74 65 2d 6e 61 6d 65 29 0a 09 09 09 20 20 uite-name)....
0d90: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6e (common:fin
0da0: 64 2d 6c 6f 63 61 6c 2d 6d 65 67 61 74 65 73 74 d-local-megatest
0db0: 29 0a 09 09 09 20 20 20 20 20 20 20 72 75 6e 2d ).... run-
0dc0: 69 64 29 29 29 29 0a 20 20 20 20 28 69 66 20 63 id)))). (if c
0dd0: 6f 6e 6e 0a 09 28 62 65 67 69 6e 20 0a 20 20 20 onn..(begin .
0de0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
0df0: 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 int-info 2 *defa
0e00: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 ult-log-port* "a
0e10: 6c 72 65 61 64 79 20 63 6f 6e 6e 65 63 74 65 64 lready connected
0e20: 20 74 6f 20 61 20 73 65 72 76 65 72 22 29 0a 20 to a server").
0e30: 20 20 20 20 20 20 20 20 20 20 63 6f 6e 6e 29 20 conn)
0e40: 3b 3b 20 77 65 20 61 72 65 20 61 6c 72 65 61 64 ;; we are alread
0e50: 79 20 63 6f 6e 6e 65 63 74 65 64 20 74 6f 20 74 y connected to t
0e60: 68 65 20 73 65 72 76 65 72 0a 09 28 6c 65 74 2a he server..(let*
0e70: 20 28 28 73 64 61 74 20 28 74 74 3a 67 65 74 2d ((sdat (tt:get-
0e80: 63 75 72 72 65 6e 74 2d 73 65 72 76 65 72 2d 69 current-server-i
0e90: 6e 66 6f 20 74 74 64 61 74 20 64 62 66 6e 61 6d nfo ttdat dbfnam
0ea0: 65 29 29 29 0a 09 20 20 28 6d 61 74 63 68 20 73 e))).. (match s
0eb0: 64 61 74 0a 09 20 20 20 20 28 28 68 6f 73 74 20 dat.. ((host
0ec0: 70 6f 72 74 20 73 74 61 72 74 2d 74 69 6d 65 20 port start-time
0ed0: 73 65 72 76 65 72 2d 69 64 20 70 69 64 20 64 62 server-id pid db
0ee0: 66 6e 61 6d 65 32 20 73 65 72 76 69 6e 66 66 69 fname2 servinffi
0ef0: 6c 65 29 0a 09 20 20 20 20 20 28 61 73 73 65 72 le).. (asser
0f00: 74 20 28 65 71 75 61 6c 3f 20 64 62 66 6e 61 6d t (equal? dbfnam
0f10: 65 20 64 62 66 6e 61 6d 65 32 29 20 22 46 41 54 e dbfname2) "FAT
0f20: 41 4c 3a 20 72 65 61 64 20 73 65 72 76 65 72 20 AL: read server
0f30: 69 6e 66 6f 20 66 72 6f 6d 20 77 72 6f 6e 67 20 info from wrong
0f40: 66 69 6c 65 2e 22 29 0a 20 20 20 20 20 20 20 20 file.").
0f50: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
0f60: 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
0f70: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 20 t-log-port* "no
0f80: 63 6f 6e 6e 20 2d 20 69 6e 20 6d 61 74 63 68 20 conn - in match
0f90: 73 65 72 76 69 6e 66 66 69 6c 65 3a 22 20 73 65 servinffile:" se
0fa0: 72 76 69 6e 66 66 69 6c 65 29 0a 09 20 20 20 20 rvinffile)..
0fb0: 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f (let* ((host-po
0fc0: 72 74 20 28 63 6f 6e 63 20 68 6f 73 74 22 3a 22 rt (conc host":"
0fd0: 70 6f 72 74 29 29 0a 09 09 20 20 20 20 28 63 6f port))... (co
0fe0: 6e 6e 20 28 6d 61 6b 65 2d 74 74 2d 63 6f 6e 6e nn (make-tt-conn
0ff0: 0a 09 09 09 20 20 20 68 6f 73 74 3a 20 68 6f 73 .... host: hos
1000: 74 0a 09 09 09 20 20 20 70 6f 72 74 3a 20 70 6f t.... port: po
1010: 72 74 0a 09 09 09 20 20 20 68 6f 73 74 2d 70 6f rt.... host-po
1020: 72 74 3a 20 68 6f 73 74 2d 70 6f 72 74 0a 09 09 rt: host-port...
1030: 09 20 20 20 64 62 66 6e 61 6d 65 3a 20 64 62 66 . dbfname: dbf
1040: 6e 61 6d 65 0a 09 09 09 20 20 20 73 65 72 76 69 name.... servi
1050: 6e 66 2d 66 69 6c 65 3a 20 73 65 72 76 69 6e 66 nf-file: servinf
1060: 66 69 6c 65 0a 09 09 09 20 20 20 73 65 72 76 65 file.... serve
1070: 72 2d 69 64 3a 20 73 65 72 76 65 72 2d 69 64 0a r-id: server-id.
1080: 09 09 09 20 20 20 73 65 72 76 65 72 2d 73 74 61 ... server-sta
1090: 72 74 3a 20 73 74 61 72 74 2d 74 69 6d 65 0a 09 rt: start-time..
10a0: 09 09 20 20 20 70 69 64 3a 20 70 69 64 29 29 29 .. pid: pid)))
10b0: 0a 09 20 20 20 20 20 20 20 3b 3b 20 76 65 72 69 .. ;; veri
10c0: 66 79 20 77 65 20 63 61 6e 20 74 61 6c 6b 20 74 fy we can talk t
10d0: 6f 20 74 68 69 73 20 73 65 72 76 65 72 0a 09 20 o this server..
10e0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 (let* ((re
10f0: 73 75 6c 74 20 20 20 28 74 74 3a 74 69 6d 65 64 sult (tt:timed
1100: 2d 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 -ping host port
1110: 73 65 72 76 65 72 2d 69 64 29 29 0a 09 09 20 20 server-id))...
1120: 20 20 20 20 28 70 69 6e 67 2d 72 65 73 20 28 63 (ping-res (c
1130: 61 72 20 72 65 73 75 6c 74 29 29 0a 09 09 20 20 ar result))...
1140: 20 20 20 20 28 70 69 6e 67 20 20 20 20 20 28 63 (ping (c
1150: 64 72 20 72 65 73 75 6c 74 29 29 29 0a 20 20 20 dr result))).
1160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
1170: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1180: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
1190: 6f 72 74 2a 20 22 68 6f 73 74 20 22 20 68 6f 73 ort* "host " hos
11a0: 74 20 22 20 70 6f 72 74 20 22 20 70 6f 72 74 20 t " port " port
11b0: 22 20 70 69 6e 67 20 74 69 6d 65 3a 20 22 20 70 " ping time: " p
11c0: 69 6e 67 20 22 20 72 65 73 75 6c 74 20 22 20 70 ing " result " p
11d0: 69 6e 67 2d 72 65 73 29 0a 09 09 20 28 63 61 73 ing-res)... (cas
11e0: 65 20 70 69 6e 67 2d 72 65 73 0a 09 09 20 20 20 e ping-res...
11f0: 28 28 72 75 6e 6e 69 6e 67 29 0a 20 20 20 20 20 ((running).
1200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1210: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1220: 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 2 *default-log-
1230: 70 6f 72 74 2a 20 22 53 65 74 74 69 6e 67 20 63 port* "Setting c
1240: 6f 6e 6e 20 3d 20 22 20 63 6f 6e 6e 20 22 20 69 onn = " conn " i
1250: 6e 20 68 61 73 68 20 74 61 62 6c 65 22 29 0a 09 n hash table")..
1260: 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
1270: 2d 73 65 74 21 20 28 74 74 2d 63 6f 6e 6e 73 20 -set! (tt-conns
1280: 74 74 64 61 74 29 20 64 62 66 6e 61 6d 65 20 63 ttdat) dbfname c
1290: 6f 6e 6e 29 20 3b 3b 3b 20 69 73 20 74 68 69 73 onn) ;;; is this
12a0: 20 6f 6b 20 74 6f 20 73 61 76 65 20 62 65 66 6f ok to save befo
12b0: 72 65 20 76 61 6c 69 64 61 74 69 6e 67 20 74 68 re validating th
12c0: 61 74 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f at the connectio
12d0: 6e 20 69 73 20 67 6f 6f 64 3f 0a 09 09 20 20 20 n is good?...
12e0: 20 63 6f 6e 6e 29 0a 09 09 20 20 20 28 28 73 74 conn)... ((st
12f0: 61 72 74 69 6e 67 29 0a 09 09 20 20 20 20 28 74 arting)... (t
1300: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a hread-sleep! 2).
1310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1320: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1330: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
1340: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 72 76 -log-port* "serv
1350: 65 72 20 66 6f 72 20 22 20 64 62 66 6e 61 6d 65 er for " dbfname
1360: 20 22 20 69 73 20 69 6e 20 73 74 61 72 74 69 6e " is in startin
1370: 67 20 73 74 61 74 65 2c 20 72 65 74 72 79 69 6e g state, retryin
1380: 67 20 63 6f 6e 6e 65 63 74 22 29 0a 09 09 20 20 g connect")...
1390: 20 20 28 74 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e (tt:client-con
13a0: 6e 65 63 74 2d 74 6f 2d 73 65 72 76 65 72 20 74 nect-to-server t
13b0: 74 64 61 74 20 64 62 66 6e 61 6d 65 20 72 75 6e tdat dbfname run
13c0: 2d 69 64 20 74 65 73 74 73 75 69 74 65 29 29 0a -id testsuite)).
13d0: 09 09 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 .. (else...
13e0: 20 28 6c 65 74 2a 20 28 28 63 75 72 72 2d 73 65 (let* ((curr-se
13f0: 63 73 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f cs (current-seco
1400: 6e 64 73 29 29 29 0a 09 09 20 20 20 20 20 20 3b nds)))... ;
1410: 3b 20 72 6d 20 74 68 65 20 28 6c 61 73 74 20 73 ; rm the (last s
1420: 65 72 76 65 72 29 20 77 6f 75 6c 64 20 67 6f 20 erver) would go
1430: 68 65 72 65 0a 09 09 20 20 20 20 20 20 28 69 66 here... (if
1440: 20 28 3e 20 28 2d 20 63 75 72 72 2d 73 65 63 73 (> (- curr-secs
1450: 20 28 74 74 2d 6c 61 73 74 2d 73 65 72 76 2d 73 (tt-last-serv-s
1460: 74 61 72 74 20 74 74 64 61 74 29 29 20 31 30 29 tart ttdat)) 10)
1470: 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 .... (begin....
1480: 20 20 20 20 28 74 74 2d 6c 61 73 74 2d 73 65 72 (tt-last-ser
1490: 76 2d 73 74 61 72 74 2d 73 65 74 21 20 74 74 64 v-start-set! ttd
14a0: 61 74 20 63 75 72 72 2d 73 65 63 73 29 0a 09 09 at curr-secs)...
14b0: 09 20 20 20 20 28 73 65 72 76 65 72 2d 73 74 61 . (server-sta
14c0: 72 74 2d 70 72 6f 63 29 29 29 20 3b 3b 20 73 74 rt-proc))) ;; st
14d0: 61 72 74 20 73 65 72 76 65 72 20 69 66 20 31 30 art server if 10
14e0: 20 73 65 63 20 73 69 6e 63 65 20 6c 61 73 74 20 sec since last
14f0: 61 74 74 65 6d 70 74 0a 09 09 20 20 20 20 20 20 attempt...
1500: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
1510: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1520: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
1530: 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 rint-info 2 *def
1540: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1550: 73 65 72 76 65 72 20 70 69 6e 67 20 72 65 73 75 server ping resu
1560: 6c 74 20 77 61 73 20 6e 65 69 74 68 65 72 20 72 lt was neither r
1570: 75 6e 6e 69 6e 67 20 6e 6f 72 20 73 74 61 72 74 unning nor start
1580: 69 6e 67 2e 20 52 65 74 72 79 69 6e 67 20 63 6f ing. Retrying co
1590: 6e 6e 65 63 74 22 29 0a 09 09 20 20 20 20 20 20 nnect")...
15a0: 28 74 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 (tt:client-conne
15b0: 63 74 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 64 ct-to-server ttd
15c0: 61 74 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 at dbfname run-i
15d0: 64 20 74 65 73 74 73 75 69 74 65 29 29 29 29 29 d testsuite)))))
15e0: 29 29 0a 09 20 20 20 20 28 65 6c 73 65 20 3b 3b )).. (else ;;
15f0: 20 6e 6f 20 67 6f 6f 64 20 73 65 72 76 65 72 20 no good server
1600: 66 6f 75 6e 64 2c 20 69 66 20 68 61 76 65 6e 27 found, if haven'
1610: 74 20 73 74 61 72 74 65 64 20 73 65 72 76 65 72 t started server
1620: 20 69 6e 20 3e 20 35 20 73 65 63 73 2c 20 73 74 in > 5 secs, st
1630: 61 72 74 20 61 6e 6f 74 68 65 72 0a 09 20 20 20 art another..
1640: 20 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 (if (> (- (cur
1650: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 74 rent-seconds) (t
1660: 74 2d 6c 61 73 74 2d 73 65 72 76 2d 73 74 61 72 t-last-serv-star
1670: 74 20 74 74 64 61 74 29 29 20 33 29 20 3b 3b 20 t ttdat)) 3) ;;
1680: 42 55 47 20 2d 20 67 72 6f 77 20 74 68 69 73 20 BUG - grow this
1690: 6e 75 6d 62 65 72 20 72 65 61 6c 6c 79 20 64 6f number really do
16a0: 20 6e 6f 74 20 77 61 6e 74 20 74 6f 20 73 77 61 not want to swa
16b0: 6d 70 20 74 68 65 20 6d 61 63 68 69 6e 65 20 77 mp the machine w
16c0: 69 74 68 20 73 65 72 76 65 72 73 0a 09 09 20 28 ith servers... (
16d0: 62 65 67 69 6e 0a 09 09 20 20 20 28 64 65 62 75 begin... (debu
16e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
16f0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1700: 2a 20 22 53 74 61 72 74 69 6e 67 20 73 65 72 76 * "Starting serv
1710: 65 72 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 29 er for "dbfname)
1720: 0a 09 09 20 20 20 28 73 65 72 76 65 72 2d 73 74 ... (server-st
1730: 61 72 74 2d 70 72 6f 63 29 0a 09 09 20 20 20 28 art-proc)... (
1740: 74 74 2d 6c 61 73 74 2d 73 65 72 76 2d 73 74 61 tt-last-serv-sta
1750: 72 74 2d 73 65 74 21 20 74 74 64 61 74 20 28 63 rt-set! ttdat (c
1760: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
1770: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1780: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
1790: 70 21 20 33 29 0a 20 20 20 20 20 20 20 20 20 20 p! 3).
17a0: 20 20 20 20 20 20 20 20 20 29 29 0a 09 20 20 20 ))..
17b0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
17c0: 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1).
17d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
17e0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
17f0: 67 2d 70 6f 72 74 2a 20 22 43 6f 6e 6e 65 63 74 g-port* "Connect
1800: 20 74 6f 20 73 65 72 76 65 72 20 66 6f 72 20 22 to server for "
1810: 20 64 62 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 dbfname)..
1820: 28 74 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 (tt:client-conne
1830: 63 74 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 64 ct-to-server ttd
1840: 61 74 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 at dbfname run-i
1850: 64 20 74 65 73 74 73 75 69 74 65 29 29 29 29 29 d testsuite)))))
1860: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a ))..(define (tt:
1870: 74 69 6d 65 64 2d 70 69 6e 67 20 68 6f 73 74 20 timed-ping host
1880: 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 29 0a port server-id).
1890: 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 2d (let* ((start-
18a0: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 time (current-mi
18b0: 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 lliseconds)).. (
18c0: 72 65 73 75 6c 74 20 20 20 20 20 28 74 74 3a 70 result (tt:p
18d0: 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 73 65 ing host port se
18e0: 72 76 65 72 2d 69 64 29 29 29 0a 20 20 20 20 28 rver-id))). (
18f0: 63 6f 6e 73 20 72 65 73 75 6c 74 20 28 2d 20 28 cons result (- (
1900: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
1910: 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 onds) start-time
1920: 29 29 29 29 0a 20 20 20 20 0a 0a 28 64 65 66 69 )))). ..(defi
1930: 6e 65 20 28 74 74 3a 70 69 6e 67 20 68 6f 73 74 ne (tt:ping host
1940: 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 20 port server-id
1950: 23 21 6f 70 74 69 6f 6e 61 6c 20 28 74 72 69 65 #!optional (trie
1960: 73 2d 6c 65 66 74 20 35 29 29 0a 20 20 28 6c 65 s-left 5)). (le
1970: 74 2a 20 20 28 28 72 65 73 20 20 20 20 20 20 28 t* ((res (
1980: 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d tt:send-receive-
1990: 64 69 72 65 63 74 20 68 6f 73 74 20 70 6f 72 74 direct host port
19a0: 20 60 28 70 69 6e 67 20 23 66 20 23 66 20 23 66 `(ping #f #f #f
19b0: 29 20 70 69 6e 67 2d 6d 6f 64 65 3a 20 23 74 29 ) ping-mode: #t)
19c0: 29 20 3b 3b 20 70 6c 65 61 73 65 20 73 65 6e 64 ) ;; please send
19d0: 20 6d 65 20 79 6f 75 72 20 73 65 72 76 65 72 2d me your server-
19e0: 69 64 0a 09 20 20 28 74 72 79 2d 61 67 61 69 6e id.. (try-again
19f0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 (lambda ()...
1a00: 20 20 20 20 20 28 69 66 20 28 3e 20 74 72 69 65 (if (> trie
1a10: 73 2d 6c 65 66 74 20 30 29 0a 09 09 09 20 20 20 s-left 0)....
1a20: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 28 (begin.... (
1a30: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
1a40: 0a 09 09 09 20 20 20 20 20 28 74 74 3a 70 69 6e .... (tt:pin
1a50: 67 20 68 6f 73 74 20 70 6f 72 74 20 73 65 72 76 g host port serv
1a60: 65 72 2d 69 64 20 28 2d 20 74 72 69 65 73 2d 6c er-id (- tries-l
1a70: 65 66 74 20 31 29 29 29 0a 09 09 09 20 20 20 23 eft 1))).... #
1a80: 66 29 29 29 29 0a 20 20 20 20 3b 3b 0a 20 20 20 f)))). ;;.
1a90: 20 3b 3b 20 6e 65 65 64 20 74 77 6f 20 74 68 72 ;; need two thr
1aa0: 65 61 64 73 2c 20 6f 6e 65 20 61 20 35 20 73 65 eads, one a 5 se
1ab0: 63 6f 6e 64 20 74 69 6d 65 72 0a 20 20 20 20 3b cond timer. ;
1ac0: 3b 0a 20 20 20 20 28 6d 61 74 63 68 20 72 65 73 ;. (match res
1ad0: 0a 20 20 20 20 20 20 28 28 73 74 61 74 75 73 20 . ((status
1ae0: 65 72 72 6d 73 67 20 72 65 73 75 6c 74 20 6d 65 errmsg result me
1af0: 74 61 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 ta). (if (
1b00: 65 71 75 61 6c 3f 20 72 65 73 75 6c 74 20 73 65 equal? result se
1b10: 72 76 65 72 2d 69 64 29 0a 09 20 20 20 28 6c 65 rver-id).. (le
1b20: 74 2a 20 28 28 73 65 72 76 65 72 2d 73 74 61 74 t* ((server-stat
1b30: 65 20 28 61 6c 69 73 74 2d 72 65 66 20 27 73 73 e (alist-ref 'ss
1b40: 74 61 74 65 20 6d 65 74 61 29 29 29 0a 09 20 20 tate meta)))..
1b50: 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
1b60: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1b70: 67 2d 70 6f 72 74 2a 20 22 50 69 6e 67 20 74 6f g-port* "Ping to
1b80: 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 20 73 "host":"port" s
1b90: 75 63 63 65 73 73 66 75 6c 2e 22 29 0a 09 20 20 uccessful.")..
1ba0: 20 20 20 28 6f 72 20 73 65 72 76 65 72 2d 73 74 (or server-st
1bb0: 61 74 65 20 27 75 6e 6b 29 29 20 3b 3b 20 74 68 ate 'unk)) ;; th
1bc0: 65 6e 20 77 65 20 61 72 65 20 67 6f 6f 64 0a 09 en we are good..
1bd0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
1be0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1bf0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1c00: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 65 72 76 * "WARNING: serv
1c10: 65 72 2d 69 64 20 64 6f 65 73 20 6e 6f 74 20 6d er-id does not m
1c20: 61 74 63 68 2c 20 65 78 70 65 63 74 65 64 3a 20 atch, expected:
1c30: 22 73 65 72 76 65 72 2d 69 64 22 2c 20 67 6f 74 "server-id", got
1c40: 3a 20 22 72 65 73 75 6c 74 29 0a 09 20 20 20 20 : "result)..
1c50: 20 23 66 29 29 29 0a 20 20 20 20 20 20 28 65 6c #f))). (el
1c60: 73 65 0a 20 20 20 20 20 20 20 3b 3b 20 28 64 65 se. ;; (de
1c70: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
1c80: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1c90: 72 65 73 20 6e 6f 74 20 69 6e 20 66 6f 72 6d 20 res not in form
1ca0: 28 73 74 61 74 75 73 20 65 72 72 6d 73 67 20 72 (status errmsg r
1cb0: 65 73 75 6c 74 20 6d 65 74 61 29 2c 20 67 6f 74 esult meta), got
1cc0: 3a 20 22 72 65 73 29 0a 20 20 20 20 20 20 20 28 : "res). (
1cd0: 74 72 79 2d 61 67 61 69 6e 29 29 29 29 29 0a 0a try-again)))))..
1ce0: 3b 3b 20 63 6c 69 65 6e 74 20 73 69 64 65 20 68 ;; client side h
1cf0: 61 6e 64 6c 65 72 0a 3b 3b 0a 3b 3b 28 74 74 3a andler.;;.;;(tt:
1d00: 68 61 6e 64 6c 65 72 20 23 3c 74 74 3e 20 67 65 handler #<tt> ge
1d10: 74 2d 6b 65 79 73 20 23 66 20 28 29 20 32 20 23 t-keys #f () 2 #
1d20: 66 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 64 61 f "/home/matt/da
1d30: 74 61 2f 6d 65 67 61 74 65 73 74 2f 65 78 74 2d ta/megatest/ext-
1d40: 74 65 73 74 73 22 20 23 66 20 22 6d 61 69 6e 2e tests" #f "main.
1d50: 64 62 22 20 22 65 78 74 2d 74 65 73 74 73 22 20 db" "ext-tests"
1d60: 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 64 61 74 61 "/home/matt/data
1d70: 2f 6d 65 67 61 74 65 73 74 2f 62 69 6e 2f 2e 32 /megatest/bin/.2
1d80: 32 2e 30 34 2f 2e 2e 2f 6d 65 67 61 74 65 73 74 2.04/../megatest
1d90: 22 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ").;;.(define (t
1da0: 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 t:handler ttdat
1db0: 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d cmd run-id param
1dc0: 73 20 61 74 74 65 6d 70 74 6e 75 6d 20 61 72 65 s attemptnum are
1dd0: 61 2d 64 61 74 20 61 72 65 61 70 61 74 68 20 72 a-dat areapath r
1de0: 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 eadonly-mode dbf
1df0: 6e 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d name testsuite m
1e00: 74 65 78 65 29 0a 20 20 28 64 65 62 75 67 3a 70 texe). (debug:p
1e10: 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d rint 2 *default-
1e20: 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 74 3a 68 61 log-port* "tt:ha
1e30: 6e 64 6c 65 72 20 63 6d 64 3a 20 22 20 63 6d 64 ndler cmd: " cmd
1e40: 20 22 20 72 75 6e 2d 69 64 3a 20 22 20 72 75 6e " run-id: " run
1e50: 2d 69 64 20 22 20 61 74 74 65 6d 70 74 6e 75 6d -id " attemptnum
1e60: 3a 20 22 20 61 74 74 65 6d 70 74 6e 75 6d 29 0a : " attemptnum).
1e70: 20 20 3b 3b 20 4e 4f 54 45 3a 20 61 72 65 61 70 ;; NOTE: areap
1e80: 61 74 68 20 69 73 20 70 61 73 73 65 64 20 69 6e ath is passed in
1e90: 20 61 6e 64 20 69 6e 20 74 74 20 73 74 72 75 63 and in tt struc
1ea0: 74 2e 20 57 65 27 6c 6c 20 75 73 65 20 70 61 73 t. We'll use pas
1eb0: 73 65 64 20 69 6e 20 76 61 6c 75 65 20 66 6f 72 sed in value for
1ec0: 20 6e 6f 77 2e 0a 20 20 3b 3b 20 63 6f 6e 6e 65 now.. ;; conne
1ed0: 63 74 2d 74 6f 2d 73 65 72 76 65 72 20 77 69 6c ct-to-server wil
1ee0: 6c 20 73 74 61 72 74 20 61 20 73 65 72 76 65 72 l start a server
1ef0: 20 69 66 20 6e 65 65 64 65 64 2e 0a 20 20 28 6c if needed.. (l
1f00: 65 74 2a 20 28 28 63 6f 6e 6e 20 28 74 74 3a 63 et* ((conn (tt:c
1f10: 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f lient-connect-to
1f20: 2d 73 65 72 76 65 72 20 74 74 64 61 74 20 64 62 -server ttdat db
1f30: 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 fname run-id tes
1f40: 74 73 75 69 74 65 29 29 29 20 3b 3b 20 28 68 61 tsuite))) ;; (ha
1f50: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
1f60: 61 75 6c 74 20 28 74 74 2d 63 6f 6e 6e 73 20 74 ault (tt-conns t
1f70: 74 64 61 74 29 20 64 62 66 6e 61 6d 65 20 23 66 tdat) dbfname #f
1f80: 29 29 29 0a 20 20 20 20 28 69 66 20 63 6f 6e 6e ))). (if conn
1f90: 0a 09 3b 3b 20 68 61 76 65 20 63 6f 6e 6e 65 63 ..;; have connec
1fa0: 74 69 6f 6e 2c 20 63 61 6c 6c 20 74 68 65 20 73 tion, call the s
1fb0: 65 72 76 65 72 0a 09 28 6c 65 74 2a 20 28 28 72 erver..(let* ((r
1fc0: 65 73 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 es (tt:send-rece
1fd0: 69 76 65 20 74 74 64 61 74 20 63 6f 6e 6e 20 63 ive ttdat conn c
1fe0: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
1ff0: 29 29 29 0a 09 20 20 3b 3b 20 72 65 73 20 69 73 ))).. ;; res is
2000: 20 28 73 74 61 74 75 73 20 65 72 72 6d 73 67 20 (status errmsg
2010: 72 65 73 75 6c 74 20 6d 65 74 61 29 0a 20 20 20 result meta).
2020: 20 20 20 20 20 20 3b 20 28 64 65 62 75 67 3a 70 ; (debug:p
2030: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2040: 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6e 6e 3a log-port* "conn:
2050: 22 20 63 6f 6e 6e 20 22 20 72 65 73 3a 20 22 20 " conn " res: "
2060: 72 65 73 29 0a 09 20 20 28 6d 61 74 63 68 20 72 res).. (match r
2070: 65 73 0a 09 20 20 20 20 28 28 73 74 61 74 75 73 es.. ((status
2080: 20 65 72 72 6d 73 67 20 72 65 73 75 6c 74 20 6d errmsg result m
2090: 65 74 61 29 0a 09 20 20 20 20 20 28 69 66 20 28 eta).. (if (
20a0: 6c 69 73 74 3f 20 6d 65 74 61 29 0a 09 09 20 28 list? meta)... (
20b0: 6c 65 74 2a 20 28 28 64 65 6c 61 79 2d 77 61 69 let* ((delay-wai
20c0: 74 20 28 61 6c 69 73 74 2d 72 65 66 20 27 64 65 t (alist-ref 'de
20d0: 6c 61 79 2d 77 61 69 74 20 6d 65 74 61 29 29 29 lay-wait meta)))
20e0: 0a 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 28 ... (if (and (
20f0: 6e 75 6d 62 65 72 3f 20 64 65 6c 61 79 2d 77 61 number? delay-wa
2100: 69 74 29 0a 09 09 09 20 20 20 20 28 3e 20 64 65 it).... (> de
2110: 6c 61 79 2d 77 61 69 74 20 30 29 29 0a 09 09 20 lay-wait 0))...
2120: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
2130: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2140: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2150: 74 2a 20 22 53 65 72 76 65 72 20 69 73 20 6c 6f t* "Server is lo
2160: 61 64 65 64 2c 20 64 65 6c 61 79 69 6e 67 20 22 aded, delaying "
2170: 64 65 6c 61 79 2d 77 61 69 74 22 20 73 65 63 6f delay-wait" seco
2180: 6e 64 73 22 29 0a 09 09 09 20 28 74 68 72 65 61 nds").... (threa
2190: 64 2d 73 6c 65 65 70 21 20 64 65 6c 61 79 2d 77 d-sleep! delay-w
21a0: 61 69 74 29 29 29 29 29 0a 09 20 20 20 20 20 28 ait))))).. (
21b0: 63 61 73 65 20 73 74 61 74 75 73 0a 09 20 20 20 case status..
21c0: 20 20 20 20 28 28 62 75 73 79 29 20 3b 3b 20 72 ((busy) ;; r
21d0: 65 73 75 6c 74 20 77 69 6c 6c 20 62 65 20 68 6f esult will be ho
21e0: 77 20 6c 6f 6e 67 20 74 68 65 20 73 65 72 76 65 w long the serve
21f0: 72 20 77 61 6e 74 73 20 79 6f 75 20 74 6f 20 64 r wants you to d
2200: 65 6c 61 79 0a 09 09 28 6c 65 74 2a 20 28 28 64 elay...(let* ((d
2210: 6c 79 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f ly (if (number?
2220: 20 72 65 73 75 6c 74 29 20 72 65 73 75 6c 74 20 result) result
2230: 30 2e 31 29 29 29 0a 09 09 20 20 28 64 65 62 75 0.1)))... (debu
2240: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
2250: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
2260: 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 20 66 6f RNING: server fo
2270: 72 20 22 64 62 66 6e 61 6d 65 22 20 69 73 20 62 r "dbfname" is b
2280: 75 73 79 2c 20 77 69 6c 6c 20 74 72 79 20 61 67 usy, will try ag
2290: 61 69 6e 20 69 6e 20 22 64 6c 79 22 20 73 65 63 ain in "dly" sec
22a0: 6f 6e 64 73 2e 22 29 0a 09 09 20 20 28 74 68 72 onds.")... (thr
22b0: 65 61 64 2d 73 6c 65 65 70 21 20 64 6c 79 29 0a ead-sleep! dly).
22c0: 09 09 20 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 .. (tt:handler
22d0: 20 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 ttdat cmd run-i
22e0: 64 20 70 61 72 61 6d 73 20 28 2b 20 61 74 74 65 d params (+ atte
22f0: 6d 70 74 6e 75 6d 20 31 29 20 61 72 65 61 2d 64 mptnum 1) area-d
2300: 61 74 20 61 72 65 61 70 61 74 68 20 72 65 61 64 at areapath read
2310: 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d only-mode dbfnam
2320: 65 20 74 65 73 74 73 75 69 74 65 20 6d 74 65 78 e testsuite mtex
2330: 65 29 29 29 0a 09 20 20 20 20 20 20 20 28 28 6c e))).. ((l
2340: 6f 61 64 65 64 29 0a 09 09 28 64 65 62 75 67 3a oaded)...(debug:
2350: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
2360: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e -log-port* "WARN
2370: 49 4e 47 3a 20 73 65 72 76 65 72 20 66 6f 72 20 ING: server for
2380: 22 64 62 66 6e 61 6d 65 22 20 69 73 20 6c 6f 61 "dbfname" is loa
2390: 64 65 64 2c 20 73 6c 6f 77 69 6e 67 20 71 75 65 ded, slowing que
23a0: 72 69 65 73 2e 22 29 0a 09 09 28 74 74 3a 62 61 ries.")...(tt:ba
23b0: 63 6b 6f 66 66 2d 69 6e 63 72 20 28 74 74 2d 63 ckoff-incr (tt-c
23c0: 6f 6e 6e 2d 68 6f 73 74 20 63 6f 6e 6e 29 28 74 onn-host conn)(t
23d0: 74 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e t-conn-port conn
23e0: 29 29 0a 09 09 72 65 73 75 6c 74 29 20 3b 3b 20 ))...result) ;;
23f0: 28 74 74 3a 68 61 6e 64 6c 65 72 20 20 74 74 64 (tt:handler ttd
2400: 61 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 at cmd run-id pa
2410: 72 61 6d 73 20 28 2b 20 61 74 74 65 6d 70 74 6e rams (+ attemptn
2420: 75 6d 20 31 29 20 61 72 65 61 2d 64 61 74 20 61 um 1) area-dat a
2430: 72 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 reapath readonly
2440: 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 -mode dbfname te
2450: 73 74 73 75 69 74 65 20 6d 74 65 78 65 29 29 0a stsuite mtexe)).
2460: 09 20 20 20 20 20 20 20 28 65 6c 73 65 0a 09 09 . (else...
2470: 72 65 73 75 6c 74 29 29 29 0a 09 20 20 20 20 28 result))).. (
2480: 65 6c 73 65 20 3b 3b 20 64 69 64 20 6e 6f 74 20 else ;; did not
2490: 72 65 63 65 69 76 65 20 70 72 6f 70 65 72 6c 79 receive properly
24a0: 20 66 6f 72 6d 61 74 65 64 20 72 65 73 75 6c 74 formated result
24b0: 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 .. (if (not
24c0: 72 65 73 29 20 3b 3b 20 74 74 3a 73 65 6e 64 2d res) ;; tt:send-
24d0: 72 65 63 65 69 76 65 20 74 65 6c 6c 69 6e 67 20 receive telling
24e0: 75 73 20 74 68 61 74 20 63 6f 6d 6d 75 6e 69 63 us that communic
24f0: 61 74 69 6f 6e 20 66 61 69 6c 65 64 0a 09 09 20 ation failed...
2500: 28 6c 65 74 2a 20 28 28 68 6f 73 74 20 20 20 20 (let* ((host
2510: 28 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 20 63 6f (tt-conn-host co
2520: 6e 6e 29 29 0a 09 09 09 28 70 6f 72 74 20 20 20 nn))....(port
2530: 20 28 74 74 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 (tt-conn-port c
2540: 6f 6e 6e 29 29 0a 09 09 09 3b 3b 20 28 64 62 66 onn))....;; (dbf
2550: 6e 61 6d 65 20 28 74 74 2d 63 6f 6e 6e 2d 70 6f name (tt-conn-po
2560: 72 74 20 63 6f 6e 6e 29 29 20 3b 3b 20 31 39 32 rt conn)) ;; 192
2570: 2e 31 36 38 2e 30 2e 31 32 37 3a 34 32 34 32 2d .168.0.127:4242-
2580: 37 32 36 39 32 34 3a 34 2e 64 62 0a 09 09 09 28 726924:4.db....(
2590: 70 69 64 20 20 20 20 20 28 74 74 2d 63 6f 6e 6e pid (tt-conn
25a0: 2d 70 69 64 20 20 63 6f 6e 6e 29 29 0a 20 20 20 -pid conn)).
25b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
25c0: 20 20 20 20 20 3b 3b 28 73 65 72 76 69 6e 66 20 ;;(servinf
25d0: 28 74 74 2d 63 6f 6e 6e 2d 73 65 72 76 69 6e 66 (tt-conn-servinf
25e0: 2d 66 69 6c 65 20 63 6f 6e 6e 29 29 29 20 0a 09 -file conn))) ..
25f0: 09 09 28 73 65 72 76 69 6e 66 20 28 74 74 2d 73 ..(servinf (tt-s
2600: 65 72 76 69 6e 66 2d 66 69 6c 65 20 74 74 64 61 ervinf-file ttda
2610: 74 29 29 29 20 3b 3b 20 28 63 6f 6e 63 20 61 72 t))) ;; (conc ar
2620: 65 61 70 61 74 68 22 2f 2e 73 65 72 76 69 6e 66 eapath"/.servinf
2630: 6f 2f 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 2d o/"host":"port"-
2640: 22 70 69 64 22 3a 22 64 62 66 6e 61 6d 65 29 29 "pid":"dbfname))
2650: 29 20 3b 3b 20 54 4f 44 4f 2c 20 75 73 65 20 28 ) ;; TODO, use (
2660: 73 65 72 76 65 72 3a 67 65 74 2d 73 65 72 76 69 server:get-servi
2670: 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 61 74 68 nfo-dir areapath
2680: 29 0a 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 )... (hash-tab
2690: 6c 65 2d 73 65 74 21 20 28 74 74 2d 63 6f 6e 6e le-set! (tt-conn
26a0: 73 20 74 74 64 61 74 29 20 64 62 66 6e 61 6d 65 s ttdat) dbfname
26b0: 20 23 66 29 0a 09 09 20 20 20 28 69 66 20 28 61 #f)... (if (a
26c0: 6e 64 20 73 65 72 76 69 6e 66 20 28 66 69 6c 65 nd servinf (file
26d0: 2d 65 78 69 73 74 73 3f 20 73 65 72 76 69 6e 66 -exists? servinf
26e0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 ))... (beg
26f0: 69 6e 0a 09 09 09 20 28 69 66 20 28 3c 20 61 74 in.... (if (< at
2700: 74 65 6d 70 74 6e 75 6d 20 31 30 29 0a 09 09 09 temptnum 10)....
2710: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 (begin....
2720: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
2730: 65 65 70 21 20 30 2e 35 29 0a 09 09 09 20 20 20 eep! 0.5)....
2740: 20 20 20 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 (tt:handler
2750: 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 64 ttdat cmd run-id
2760: 20 70 61 72 61 6d 73 20 28 2b 20 61 74 74 65 6d params (+ attem
2770: 70 74 6e 75 6d 20 31 29 20 61 72 65 61 2d 64 61 ptnum 1) area-da
2780: 74 20 61 72 65 61 70 61 74 68 20 72 65 61 64 6f t areapath reado
2790: 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 nly-mode dbfname
27a0: 20 74 65 73 74 73 75 69 74 65 20 6d 74 65 78 65 testsuite mtexe
27b0: 29 29 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 )).... (begi
27c0: 6e 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 n.... (deb
27d0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
27e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
27f0: 4e 46 4f 3a 20 6e 6f 20 72 65 73 70 6f 6e 73 65 NFO: no response
2800: 20 66 72 6f 6d 20 73 65 72 76 65 72 20 22 68 6f from server "ho
2810: 73 74 22 3a 22 70 6f 72 74 22 20 66 6f 72 20 22 st":"port" for "
2820: 64 62 66 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 dbfname)....
2830: 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c (if (and (fil
2840: 65 2d 65 78 69 73 74 73 3f 20 73 65 72 76 69 6e e-exists? servin
2850: 66 29 0a 09 09 09 09 09 28 3e 20 28 2d 20 28 63 f)......(> (- (c
2860: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
2870: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
2880: 6e 2d 74 69 6d 65 20 73 65 72 76 69 6e 66 29 29 n-time servinf))
2890: 20 36 30 29 29 0a 09 09 09 09 20 20 20 28 62 65 60))..... (be
28a0: 67 69 6e 0a 09 09 09 09 20 20 20 20 20 28 64 65 gin..... (de
28b0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
28c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
28d0: 49 4e 46 4f 3a 20 22 73 65 72 76 69 6e 66 22 20 INFO: "servinf"
28e0: 66 69 6c 65 20 73 65 65 6d 73 20 6f 6c 64 20 61 file seems old a
28f0: 6e 64 20 6e 6f 20 70 69 6e 67 20 72 65 73 70 6f nd no ping respo
2900: 6e 73 65 2c 20 72 65 6d 6f 76 69 6e 67 20 69 74 nse, removing it
2910: 2e 22 29 0a 09 09 09 09 20 20 20 20 20 28 68 61 .")..... (ha
2920: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
2930: 09 09 09 09 09 20 65 78 6e 0a 09 09 09 09 20 20 ..... exn.....
2940: 20 20 20 20 20 23 66 0a 09 09 09 09 20 20 20 20 #f.....
2950: 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a (delete-file*
2960: 20 73 65 72 76 69 6e 66 29 29 0a 09 09 09 09 20 servinf)).....
2970: 20 20 20 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 (tt:handler
2980: 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 64 ttdat cmd run-id
2990: 20 70 61 72 61 6d 73 20 28 2b 20 61 74 74 65 6d params (+ attem
29a0: 70 74 6e 75 6d 20 31 29 20 61 72 65 61 2d 64 61 ptnum 1) area-da
29b0: 74 20 61 72 65 61 70 61 74 68 20 72 65 61 64 6f t areapath reado
29c0: 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 nly-mode dbfname
29d0: 20 74 65 73 74 73 75 69 74 65 20 6d 74 65 78 65 testsuite mtexe
29e0: 29 29 0a 09 09 09 09 20 20 20 28 62 65 67 69 6e ))..... (begin
29f0: 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 73 74 61 ..... ;; sta
2a00: 72 74 20 73 65 72 76 65 72 20 2d 20 61 64 64 72 rt server - addr
2a10: 65 73 73 65 64 20 69 6e 20 63 6c 69 65 6e 74 2d essed in client-
2a20: 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 65 connect-to-serve
2a30: 72 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 64 65 r..... ;; de
2a40: 6c 61 79 20 20 20 20 20 20 20 20 2d 20 61 64 64 lay - add
2a50: 72 65 73 73 65 64 20 69 6e 20 63 6c 69 65 6e 74 ressed in client
2a60: 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 -connect-to-serv
2a70: 65 72 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 74 er..... ;; t
2a80: 72 79 20 61 67 61 69 6e 0a 09 09 09 09 20 20 20 ry again.....
2a90: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
2aa0: 20 30 2e 32 35 29 20 3b 3b 20 64 75 6e 6e 6f 2c 0.25) ;; dunno,
2ab0: 20 49 20 74 68 69 6e 6b 20 74 68 69 73 20 6e 65 I think this ne
2ac0: 65 64 73 20 74 6f 20 62 65 20 68 65 72 65 0a 09 eds to be here..
2ad0: 09 09 09 20 20 20 20 20 28 74 74 3a 68 61 6e 64 ... (tt:hand
2ae0: 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 75 ler ttdat cmd ru
2af0: 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 2b 20 61 n-id params (+ a
2b00: 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 61 72 65 ttemptnum 1) are
2b10: 61 2d 64 61 74 20 61 72 65 61 70 61 74 68 20 72 a-dat areapath r
2b20: 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 eadonly-mode dbf
2b30: 6e 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d name testsuite m
2b40: 74 65 78 65 29 29 0a 09 09 09 09 20 20 20 29 29 texe))..... ))
2b50: 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 ))... (beg
2b60: 69 6e 20 3b 3b 20 6e 6f 20 73 65 72 76 65 72 20 in ;; no server
2b70: 66 69 6c 65 2c 20 64 65 6c 61 79 20 61 6e 64 20 file, delay and
2b80: 74 72 79 20 61 67 61 69 6e 0a 09 09 09 20 28 64 try again.... (d
2b90: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 ebug:print 2 *de
2ba0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2bb0: 22 49 4e 46 4f 3a 20 63 6f 6e 6e 65 63 74 69 6f "INFO: connectio
2bc0: 6e 20 74 6f 20 73 65 72 76 65 72 20 22 68 6f 73 n to server "hos
2bd0: 74 22 3a 22 70 6f 72 74 22 20 62 72 6f 6b 65 6e t":"port" broken
2be0: 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 22 2c 20 for "dbfname",
2bf0: 6e 6f 20 73 65 72 76 69 6e 66 20 66 69 6c 65 2e no servinf file.
2c00: 20 53 65 72 76 65 72 20 65 78 69 74 65 64 3f 20 Server exited?
2c10: 22 29 0a 09 09 09 20 28 74 68 72 65 61 64 2d 73 ").... (thread-s
2c20: 6c 65 65 70 21 20 30 2e 35 29 0a 09 09 09 20 28 leep! 0.5).... (
2c30: 74 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 74 tt:handler ttdat
2c40: 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 cmd run-id para
2c50: 6d 73 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d ms (+ attemptnum
2c60: 20 31 29 20 61 72 65 61 2d 64 61 74 20 61 72 65 1) area-dat are
2c70: 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d apath readonly-m
2c80: 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 74 ode dbfname test
2c90: 73 75 69 74 65 20 6d 74 65 78 65 29 29 29 29 0a suite mtexe)))).
2ca0: 09 09 20 28 62 65 67 69 6e 20 3b 3b 20 74 68 69 .. (begin ;; thi
2cb0: 73 20 63 61 73 65 20 69 73 20 77 68 65 72 65 20 s case is where
2cc0: 72 65 73 20 69 73 20 6d 61 6c 66 6f 72 6d 65 64 res is malformed
2cd0: 2e 20 50 72 6f 62 61 62 6c 79 20 73 68 6f 75 6c . Probably shoul
2ce0: 64 20 61 62 6f 72 74 0a 09 09 20 20 20 28 61 73 d abort... (as
2cf0: 73 65 72 74 20 23 66 20 22 46 41 54 41 4c 3a 20 sert #f "FATAL:
2d00: 74 74 3a 68 61 6e 64 6c 65 72 20 72 65 63 65 69 tt:handler recei
2d10: 76 65 64 20 62 61 64 20 64 61 74 61 20 22 72 65 ved bad data "re
2d20: 73 29 0a 09 09 20 20 20 3b 3b 20 28 64 65 62 75 s)... ;; (debu
2d30: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
2d40: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
2d50: 46 4f 3a 20 67 6f 74 20 63 6f 72 72 75 70 74 20 FO: got corrupt
2d60: 64 61 74 61 20 66 72 6f 6d 20 73 65 72 76 65 72 data from server
2d70: 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 2c 20 "host":"port",
2d80: 22 72 65 73 22 2c 20 66 6f 72 20 22 64 62 66 6e "res", for "dbfn
2d90: 61 6d 65 22 2c 20 77 69 6c 6c 20 74 72 79 20 61 ame", will try a
2da0: 67 61 69 6e 2e 22 29 0a 09 09 20 20 20 3b 3b 20 gain.")... ;;
2db0: 28 74 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 (tt:handler ttda
2dc0: 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 t cmd run-id par
2dd0: 61 6d 73 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 ams (+ attemptnu
2de0: 6d 20 31 29 20 61 72 65 61 2d 64 61 74 20 61 72 m 1) area-dat ar
2df0: 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d eapath readonly-
2e00: 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 mode dbfname tes
2e10: 74 73 75 69 74 65 20 6d 74 65 78 65 29 0a 09 09 tsuite mtexe)...
2e20: 20 20 20 29 29 29 29 29 0a 09 28 62 65 67 69 6e )))))..(begin
2e30: 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
2e40: 70 21 20 31 29 20 3b 3b 20 6e 6f 20 63 6f 6e 6e p! 1) ;; no conn
2e50: 20 79 65 74 20 73 65 74 20 75 70 2c 20 67 69 76 yet set up, giv
2e60: 65 20 69 74 20 61 20 72 65 73 74 20 61 6e 64 20 e it a rest and
2e70: 74 72 79 20 61 67 61 69 6e 0a 09 20 20 28 74 74 try again.. (tt
2e80: 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 :handler ttdat c
2e90: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
2ea0: 20 61 74 74 65 6d 70 74 6e 75 6d 20 61 72 65 61 attemptnum area
2eb0: 2d 64 61 74 20 61 72 65 61 70 61 74 68 20 72 65 -dat areapath re
2ec0: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e adonly-mode dbfn
2ed0: 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d 74 ame testsuite mt
2ee0: 65 78 65 29 29 29 29 29 0a 0a 28 64 65 66 69 6e exe)))))..(defin
2ef0: 65 20 28 74 74 3a 62 69 64 2d 66 6f 72 2d 73 65 e (tt:bid-for-se
2f00: 72 76 65 72 73 68 69 70 20 72 75 6e 2d 69 64 29 rvership run-id)
2f10: 0a 20 20 23 66 29 0a 0a 3b 3b 20 67 65 74 73 20 . #f)..;; gets
2f20: 73 65 72 76 65 72 20 69 6e 66 6f 20 61 6e 64 20 server info and
2f30: 61 70 70 65 6e 64 73 20 70 61 74 68 20 74 6f 20 appends path to
2f40: 73 65 72 76 65 72 20 66 69 6c 65 0a 3b 3b 20 73 server file.;; s
2f50: 6f 72 74 73 20 62 79 20 61 67 65 2c 20 6f 6c 64 orts by age, old
2f60: 65 73 74 20 66 69 72 73 74 0a 3b 3b 0a 3b 3b 20 est first.;;.;;
2f70: 72 65 74 75 72 6e 73 20 6c 69 73 74 20 6f 66 20 returns list of
2f80: 28 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 (host port start
2f90: 73 65 63 6f 6e 64 73 20 73 65 72 76 65 72 2d 69 seconds server-i
2fa0: 64 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a d servinfofile).
2fb0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 67 ;;.(define (tt:g
2fc0: 65 74 2d 73 65 72 76 65 72 2d 69 6e 66 6f 2d 73 et-server-info-s
2fd0: 6f 72 74 65 64 20 74 74 64 61 74 20 64 62 66 6e orted ttdat dbfn
2fe0: 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 ame). (let* ((a
2ff0: 72 65 61 70 61 74 68 20 28 74 74 2d 61 72 65 61 reapath (tt-area
3000: 70 61 74 68 20 74 74 64 61 74 29 29 0a 09 20 28 path ttdat)).. (
3010: 73 66 69 6c 65 73 20 20 20 28 74 74 3a 66 69 6e sfiles (tt:fin
3020: 64 2d 73 65 72 76 65 72 20 61 72 65 61 70 61 74 d-server areapat
3030: 68 20 64 62 66 6e 61 6d 65 29 29 0a 09 20 28 73 h dbfname)).. (s
3040: 64 61 74 73 20 20 20 20 28 66 69 6c 74 65 72 20 dats (filter
3050: 63 61 72 20 28 6d 61 70 20 74 74 3a 73 65 72 76 car (map tt:serv
3060: 65 72 2d 67 65 74 2d 69 6e 66 6f 20 73 66 69 6c er-get-info sfil
3070: 65 73 29 29 29 20 3b 3b 20 66 69 72 73 74 20 65 es))) ;; first e
3080: 6c 65 6d 65 6e 74 20 69 73 20 23 66 20 69 66 20 lement is #f if
3090: 74 68 65 20 66 69 6c 65 20 64 69 73 61 70 70 65 the file disappe
30a0: 61 72 65 64 20 77 68 69 6c 65 20 62 65 69 6e 67 ared while being
30b0: 20 72 65 61 64 0a 09 20 28 73 6f 72 74 65 64 20 read.. (sorted
30c0: 20 20 28 73 6f 72 74 20 73 64 61 74 73 20 28 6c (sort sdats (l
30d0: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 09 09 ambda (a b).....
30e0: 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 61 20 (let* ((starta
30f0: 28 6c 69 73 74 2d 72 65 66 20 61 20 32 29 29 0a (list-ref a 2)).
3100: 09 09 09 09 09 28 73 74 61 72 74 62 20 28 6c 69 .....(startb (li
3110: 73 74 2d 72 65 66 20 62 20 32 29 29 29 0a 09 09 st-ref b 2)))...
3120: 09 09 20 20 20 28 69 66 20 28 65 71 3f 20 73 74 .. (if (eq? st
3130: 61 72 74 61 20 73 74 61 72 74 62 29 0a 09 09 09 arta startb)....
3140: 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 3e . (string>
3150: 3f 20 28 6c 69 73 74 2d 72 65 66 20 61 20 33 29 ? (list-ref a 3)
3160: 28 6c 69 73 74 2d 72 65 66 20 62 20 33 29 29 20 (list-ref b 3))
3170: 3b 3b 20 69 66 20 73 65 72 76 65 72 73 20 73 74 ;; if servers st
3180: 61 72 74 65 64 20 61 74 20 73 61 6d 65 20 74 69 arted at same ti
3190: 6d 65 20 6c 6f 6f 6b 20 61 74 20 73 65 72 76 65 me look at serve
31a0: 72 2d 69 64 0a 09 09 09 09 20 20 20 20 20 20 20 r-id.....
31b0: 28 3c 20 73 74 61 72 74 61 20 73 74 61 72 74 62 (< starta startb
31c0: 29 29 29 29 29 29 0a 09 20 28 63 6f 75 6e 74 20 )))))).. (count
31d0: 20 20 20 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 0)). (for-
31e0: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
31f0: 61 20 28 72 65 63 29 0a 20 20 20 20 20 20 20 28 a (rec). (
3200: 69 66 20 28 6f 72 20 28 3e 20 28 6c 65 6e 67 74 if (or (> (lengt
3210: 68 20 73 6f 72 74 65 64 29 20 31 29 0a 09 20 20 h sorted) 1)..
3220: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (common:low
3230: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 -noise-print 120
3240: 20 22 73 65 72 76 65 72 20 69 6e 66 6f 20 73 6f "server info so
3250: 72 74 65 64 22 29 29 0a 09 20 20 20 28 64 65 62 rted")).. (deb
3260: 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 ug:print 2 *defa
3270: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
3280: 45 52 56 45 52 20 23 22 63 6f 75 6e 74 22 3a 20 ERVER #"count":
3290: 22 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 "(string-intersp
32a0: 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 73 erse (map conc s
32b0: 6f 72 74 65 64 29 20 22 2c 20 22 29 29 29 0a 20 orted) ", "))).
32c0: 20 20 20 20 20 20 28 73 65 74 21 20 63 6f 75 6e (set! coun
32d0: 74 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 0a t (+ count 1))).
32e0: 20 20 20 20 20 73 6f 72 74 65 64 29 0a 20 20 20 sorted).
32f0: 20 73 6f 72 74 65 64 29 29 0a 20 20 20 20 0a 28 sorted)). .(
3300: 64 65 66 69 6e 65 20 28 74 74 3a 67 65 74 2d 63 define (tt:get-c
3310: 75 72 72 65 6e 74 2d 73 65 72 76 65 72 2d 69 6e urrent-server-in
3320: 66 6f 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 fo ttdat dbfname
3330: 29 0a 20 20 28 61 73 73 65 72 74 20 28 74 74 2d ). (assert (tt-
3340: 61 72 65 61 70 61 74 68 20 74 74 64 61 74 29 20 areapath ttdat)
3350: 22 46 41 54 41 4c 3a 20 61 72 65 61 70 61 74 68 "FATAL: areapath
3360: 20 6e 6f 74 20 73 65 74 20 69 6e 20 74 74 64 61 not set in ttda
3370: 74 2e 22 29 0a 20 20 3b 3b 0a 20 20 3b 3b 20 54 t."). ;;. ;; T
3380: 4f 44 4f 20 2d 20 72 65 70 6c 61 63 65 20 6d 6f ODO - replace mo
3390: 73 74 20 6f 66 20 62 65 6c 6f 77 20 77 69 74 68 st of below with
33a0: 20 74 74 3b 67 65 74 2d 73 65 72 76 65 72 2d 69 tt;get-server-i
33b0: 6e 66 6f 2d 73 6f 72 74 65 64 0a 20 20 3b 3b 0a nfo-sorted. ;;.
33c0: 20 20 28 6c 65 74 2a 20 28 28 61 72 65 61 70 61 (let* ((areapa
33d0: 74 68 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 th (tt-areapath
33e0: 74 74 64 61 74 29 29 0a 09 20 28 73 66 69 6c 65 ttdat)).. (sfile
33f0: 73 20 20 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 s (tt:find-ser
3400: 76 65 72 20 61 72 65 61 70 61 74 68 20 64 62 66 ver areapath dbf
3410: 6e 61 6d 65 29 29 0a 09 20 28 73 64 61 74 73 20 name)).. (sdats
3420: 20 20 20 28 66 69 6c 74 65 72 20 63 61 72 20 28 (filter car (
3430: 6d 61 70 20 74 74 3a 73 65 72 76 65 72 2d 67 65 map tt:server-ge
3440: 74 2d 69 6e 66 6f 20 73 66 69 6c 65 73 29 29 29 t-info sfiles)))
3450: 20 3b 3b 20 66 69 72 73 74 20 65 6c 65 6d 65 6e ;; first elemen
3460: 74 20 69 73 20 23 66 20 69 66 20 74 68 65 20 66 t is #f if the f
3470: 69 6c 65 20 64 69 73 61 70 70 65 61 72 65 64 20 ile disappeared
3480: 77 68 69 6c 65 20 62 65 69 6e 67 20 72 65 61 64 while being read
3490: 0a 09 20 28 73 6f 72 74 65 64 20 20 20 28 73 6f .. (sorted (so
34a0: 72 74 20 73 64 61 74 73 20 28 6c 61 6d 62 64 61 rt sdats (lambda
34b0: 20 28 61 20 62 29 0a 09 09 09 09 20 28 3c 20 28 (a b)..... (< (
34c0: 6c 69 73 74 2d 72 65 66 20 61 20 32 29 28 6c 69 list-ref a 2)(li
34d0: 73 74 2d 72 65 66 20 62 20 32 29 29 29 29 29 29 st-ref b 2))))))
34e0: 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
34f0: 73 6f 72 74 65 64 29 0a 09 23 66 20 20 3b 3b 20 sorted)..#f ;;
3500: 77 65 27 6c 6c 20 77 61 6e 74 20 74 6f 20 77 61 we'll want to wa
3510: 69 74 20 75 6e 74 69 6c 20 65 78 74 72 61 20 73 it until extra s
3520: 65 72 76 65 72 73 20 68 61 76 65 20 65 78 69 74 ervers have exit
3530: 65 64 0a 09 28 63 61 72 20 73 6f 72 74 65 64 29 ed..(car sorted)
3540: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 )))..(define (tt
3550: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 74 74 :send-receive tt
3560: 64 61 74 20 63 6f 6e 6e 20 63 6d 64 20 72 75 6e dat conn cmd run
3570: 2d 69 64 20 70 61 72 61 6d 73 29 0a 20 20 28 6c -id params). (l
3580: 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 et* ((host-port
3590: 28 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 2d 70 6f (tt-conn-host-po
35a0: 72 74 20 63 6f 6e 6e 29 29 20 3b 3b 20 28 63 6f rt conn)) ;; (co
35b0: 6e 63 20 28 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 nc (tt-conn-host
35c0: 20 63 6f 6e 6e 29 22 3a 22 28 74 74 2d 63 6f 6e conn)":"(tt-con
35d0: 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 29 0a 09 n-port conn)))..
35e0: 20 28 68 6f 73 74 20 20 20 20 20 20 28 74 74 2d (host (tt-
35f0: 63 6f 6e 6e 2d 68 6f 73 74 20 63 6f 6e 6e 29 29 conn-host conn))
3600: 0a 09 20 28 70 6f 72 74 20 20 20 20 20 20 28 74 .. (port (t
3610: 74 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e t-conn-port conn
3620: 29 29 0a 09 20 28 64 61 74 20 20 20 20 20 20 20 )).. (dat
3630: 28 6c 69 73 74 20 63 6d 64 20 72 75 6e 2d 69 64 (list cmd run-id
3640: 20 70 61 72 61 6d 73 20 23 66 29 29 29 20 3b 3b params #f))) ;;
3650: 20 6e 6f 20 6d 65 74 61 20 64 61 74 61 20 79 65 no meta data ye
3660: 74 0a 20 20 20 20 28 74 74 3a 73 65 6e 64 2d 72 t. (tt:send-r
3670: 65 63 65 69 76 65 2d 64 69 72 65 63 74 20 68 6f eceive-direct ho
3680: 73 74 20 70 6f 72 74 20 64 61 74 29 29 29 0a 0a st port dat)))..
3690: 28 64 65 66 73 74 72 75 63 74 20 74 74 3a 62 61 (defstruct tt:ba
36a0: 63 6b 6f 66 66 0a 20 20 28 6c 61 73 74 2d 69 6f ckoff. (last-io
36b0: 65 72 72 20 28 63 75 72 72 65 6e 74 2d 73 65 63 err (current-sec
36c0: 6f 6e 64 73 29 29 0a 20 20 28 6c 61 73 74 2d 61 onds)). (last-a
36d0: 64 6a 2d 74 20 28 63 75 72 72 65 6e 74 2d 73 65 dj-t (current-se
36e0: 63 6f 6e 64 73 29 29 0a 20 20 28 77 61 69 74 2d conds)). (wait-
36f0: 64 65 6c 61 79 20 30 2e 31 29 29 0a 0a 28 64 65 delay 0.1))..(de
3700: 66 69 6e 65 20 2a 74 74 3a 62 61 63 6b 6f 66 66 fine *tt:backoff
3710: 2d 73 6d 6f 6f 74 68 69 6e 67 2a 20 28 6d 61 6b -smoothing* (mak
3720: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
3730: 3b 20 68 6f 73 74 3a 70 6f 72 74 20 3d 3e 20 6c ; host:port => l
3740: 61 73 74 61 63 63 65 73 73 20 62 61 63 6b 6f 66 astaccess backof
3750: 66 64 65 6c 61 79 20 29 0a 0a 28 64 65 66 69 6e fdelay )..(defin
3760: 65 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d 69 6e e (tt:backoff-in
3770: 63 72 20 68 6f 73 74 20 70 6f 72 74 29 20 3b 3b cr host port) ;;
3780: 20 63 61 6c 6c 20 69 66 20 74 63 70 20 66 61 69 call if tcp fai
3790: 6c 73 20 69 2f 6f 20 6e 65 74 0a 20 20 28 6c 65 ls i/o net. (le
37a0: 74 2a 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 28 t* ((host-port (
37b0: 63 6f 6e 63 20 68 6f 73 74 22 3a 22 70 6f 72 74 conc host":"port
37c0: 29 29 0a 09 20 28 62 6b 6f 66 66 20 20 20 20 20 )).. (bkoff
37d0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
37e0: 64 65 66 61 75 6c 74 20 2a 74 74 3a 62 61 63 6b default *tt:back
37f0: 6f 66 66 2d 73 6d 6f 6f 74 68 69 6e 67 2a 20 68 off-smoothing* h
3800: 6f 73 74 2d 70 6f 72 74 20 23 66 29 29 29 0a 20 ost-port #f))).
3810: 20 20 20 28 69 66 20 62 6b 6f 66 66 0a 09 28 62 (if bkoff..(b
3820: 65 67 69 6e 0a 09 20 20 28 74 74 3a 62 61 63 6b egin.. (tt:back
3830: 6f 66 66 2d 6c 61 73 74 2d 69 6f 65 72 72 2d 73 off-last-ioerr-s
3840: 65 74 21 20 62 6b 6f 66 66 20 28 63 75 72 72 65 et! bkoff (curre
3850: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 nt-seconds))..
3860: 28 74 74 3a 62 61 63 6b 6f 66 66 2d 77 61 69 74 (tt:backoff-wait
3870: 2d 64 65 6c 61 79 2d 73 65 74 21 20 62 6b 6f 66 -delay-set! bkof
3880: 66 20 28 2b 20 28 74 74 3a 62 61 63 6b 6f 66 66 f (+ (tt:backoff
3890: 2d 77 61 69 74 2d 64 65 6c 61 79 20 62 6b 6f 66 -wait-delay bkof
38a0: 66 29 20 30 2e 31 29 29 29 0a 09 28 68 61 73 68 f) 0.1)))..(hash
38b0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 74 3a -table-set! *tt:
38c0: 62 61 63 6b 6f 66 66 2d 73 6d 6f 6f 74 68 69 6e backoff-smoothin
38d0: 67 2a 20 68 6f 73 74 2d 70 6f 72 74 20 28 6d 61 g* host-port (ma
38e0: 6b 65 2d 74 74 3a 62 61 63 6b 6f 66 66 29 29 29 ke-tt:backoff)))
38f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a ))..(define (tt:
3900: 62 61 63 6b 6f 66 66 2d 64 65 63 72 2d 61 6e 64 backoff-decr-and
3910: 2d 77 61 69 74 20 68 6f 73 74 20 70 6f 72 74 29 -wait host port)
3920: 0a 20 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 2d . (let* ((host-
3930: 70 6f 72 74 20 28 63 6f 6e 63 20 68 6f 73 74 22 port (conc host"
3940: 3a 22 70 6f 72 74 29 29 0a 09 20 28 62 6b 6f 66 :"port)).. (bkof
3950: 66 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c f (hash-tabl
3960: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 e-ref/default *t
3970: 74 3a 62 61 63 6b 6f 66 66 2d 73 6d 6f 6f 74 68 t:backoff-smooth
3980: 69 6e 67 2a 20 68 6f 73 74 2d 70 6f 72 74 20 23 ing* host-port #
3990: 66 29 29 29 0a 20 20 20 20 28 69 66 20 62 6b 6f f))). (if bko
39a0: 66 66 0a 09 28 6c 65 74 2a 20 28 28 77 61 69 74 ff..(let* ((wait
39b0: 2d 64 65 6c 61 79 20 28 74 74 3a 62 61 63 6b 6f -delay (tt:backo
39c0: 66 66 2d 77 61 69 74 2d 64 65 6c 61 79 20 62 6b ff-wait-delay bk
39d0: 6f 66 66 29 29 0a 09 20 20 20 20 20 20 20 28 6c off)).. (l
39e0: 61 73 74 2d 69 6f 65 72 72 20 28 74 74 3a 62 61 ast-ioerr (tt:ba
39f0: 63 6b 6f 66 66 2d 6c 61 73 74 2d 69 6f 65 72 72 ckoff-last-ioerr
3a00: 20 62 6b 6f 66 66 29 29 0a 09 20 20 20 20 20 20 bkoff))..
3a10: 20 28 6c 61 73 74 2d 61 64 6a 2d 74 20 28 74 74 (last-adj-t (tt
3a20: 3a 62 61 63 6b 6f 66 66 2d 6c 61 73 74 2d 61 64 :backoff-last-ad
3a30: 6a 2d 74 20 62 6b 6f 66 66 29 29 0a 09 20 20 20 j-t bkoff))..
3a40: 20 20 20 20 28 64 65 6c 74 61 20 20 20 20 20 20 (delta
3a50: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
3a60: 6e 64 73 29 20 6c 61 73 74 2d 61 64 6a 2d 74 29 nds) last-adj-t)
3a70: 29 0a 09 20 20 20 20 20 20 20 28 61 64 6a 20 20 ).. (adj
3a80: 20 20 20 20 20 20 28 2a 20 64 65 6c 74 61 20 30 (* delta 0
3a90: 2e 30 30 31 29 29 20 3b 3b 20 69 74 20 74 61 6b .001)) ;; it tak
3aa0: 65 73 20 31 30 30 20 73 65 63 6f 6e 64 73 20 74 es 100 seconds t
3ab0: 6f 20 72 65 63 6f 76 65 72 20 66 72 6f 6d 20 68 o recover from h
3ac0: 69 74 74 69 6e 67 20 61 6e 20 69 6f 20 65 72 72 itting an io err
3ad0: 0a 09 20 20 20 20 20 20 20 28 6e 65 77 2d 77 61 .. (new-wa
3ae0: 69 74 20 20 20 28 69 66 20 28 3e 20 77 61 69 74 it (if (> wait
3af0: 2d 64 65 6c 61 79 20 30 29 0a 09 09 09 20 20 20 -delay 0)....
3b00: 20 20 20 20 28 69 66 20 28 3e 20 61 64 6a 20 77 (if (> adj w
3b10: 61 69 74 2d 64 65 6c 61 79 29 0a 09 09 09 09 20 ait-delay).....
3b20: 20 20 30 0a 09 09 09 09 20 20 20 28 2d 20 77 61 0..... (- wa
3b30: 69 74 2d 64 65 6c 61 79 20 61 64 6a 29 29 0a 09 it-delay adj))..
3b40: 09 09 20 20 20 20 20 20 20 30 29 29 29 0a 09 20 .. 0)))..
3b50: 20 28 69 66 20 28 3e 20 6e 65 77 2d 77 61 69 74 (if (> new-wait
3b60: 20 30 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 0).. (begi
3b70: 6e 0a 09 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a n...(if (common:
3b80: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
3b90: 31 30 20 22 64 65 6c 61 79 20 77 61 69 74 20 6d 10 "delay wait m
3ba0: 65 73 73 61 67 65 22 29 0a 09 09 20 20 20 20 28 essage")... (
3bb0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
3bc0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
3bd0: 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 6c 6f port* "Server lo
3be0: 61 64 65 64 2c 20 44 65 6c 61 79 57 61 69 74 3a aded, DelayWait:
3bf0: 20 22 6e 65 77 2d 77 61 69 74 29 29 0a 09 09 28 "new-wait))...(
3c00: 74 74 3a 62 61 63 6b 6f 66 66 2d 77 61 69 74 2d tt:backoff-wait-
3c10: 64 65 6c 61 79 2d 73 65 74 21 20 62 6b 6f 66 66 delay-set! bkoff
3c20: 20 6e 65 77 2d 77 61 69 74 29 0a 09 09 28 74 74 new-wait)...(tt
3c30: 3a 62 61 63 6b 6f 66 66 2d 6c 61 73 74 2d 61 64 :backoff-last-ad
3c40: 6a 2d 74 2d 73 65 74 21 20 62 6b 6f 66 66 20 28 j-t-set! bkoff (
3c50: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
3c60: 29 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 )...(thread-slee
3c70: 70 21 20 6e 65 77 2d 77 61 69 74 29 29 0a 09 20 p! new-wait))..
3c80: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
3c90: 2d 64 65 6c 65 74 65 21 20 2a 74 74 3a 62 61 63 -delete! *tt:bac
3ca0: 6b 6f 66 66 2d 73 6d 6f 6f 74 68 69 6e 67 2a 20 koff-smoothing*
3cb0: 68 6f 73 74 2d 70 6f 72 74 29 29 29 29 29 29 0a host-port)))))).
3cc0: 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 73 65 6e .(define (tt:sen
3cd0: 64 2d 72 65 63 65 69 76 65 2d 64 69 72 65 63 74 d-receive-direct
3ce0: 20 68 6f 73 74 20 70 6f 72 74 20 64 61 74 20 23 host port dat #
3cf0: 21 6b 65 79 20 28 70 69 6e 67 2d 6d 6f 64 65 20 !key (ping-mode
3d00: 23 66 29 28 74 72 69 65 73 2d 72 65 6d 61 69 6e #f)(tries-remain
3d10: 69 6e 67 20 32 35 29 29 0a 20 20 28 61 73 73 65 ing 25)). (asse
3d20: 72 74 20 28 6e 75 6d 62 65 72 3f 20 70 6f 72 74 rt (number? port
3d30: 29 20 22 46 41 54 41 4c 3a 20 74 74 3a 73 65 6e ) "FATAL: tt:sen
3d40: 64 2d 72 65 63 65 69 76 65 2d 64 69 72 65 63 74 d-receive-direct
3d50: 20 63 61 6c 6c 65 64 20 77 69 74 68 20 70 6f 72 called with por
3d60: 74 20 6e 6f 74 20 61 20 6e 75 6d 62 65 72 20 22 t not a number "
3d70: 70 6f 72 74 29 0a 20 20 28 74 74 3a 62 61 63 6b port). (tt:back
3d80: 6f 66 66 2d 64 65 63 72 2d 61 6e 64 2d 77 61 69 off-decr-and-wai
3d90: 74 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 28 t host port). (
3da0: 6c 65 74 2a 20 28 28 72 65 74 72 79 20 20 20 20 let* ((retry
3db0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
3dc0: 0a 09 09 09 20 20 20 28 74 74 3a 73 65 6e 64 2d .... (tt:send-
3dd0: 72 65 63 65 69 76 65 2d 64 69 72 65 63 74 20 68 receive-direct h
3de0: 6f 73 74 20 70 6f 72 74 20 64 61 74 20 74 72 69 ost port dat tri
3df0: 65 73 2d 72 65 6d 61 69 6e 69 6e 67 3a 20 28 2d es-remaining: (-
3e00: 20 74 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e 67 tries-remaining
3e10: 20 31 29 29 29 29 0a 09 20 28 66 75 6c 6c 2d 65 1)))).. (full-e
3e20: 72 72 2d 70 72 69 6e 74 20 28 6c 61 6d 62 64 61 rr-print (lambda
3e30: 20 28 65 78 6e 20 6d 73 67 29 0a 09 09 09 20 20 (exn msg)....
3e40: 20 28 69 66 20 28 63 6f 6e 64 69 74 69 6f 6e 3f (if (condition?
3e50: 20 65 78 6e 29 0a 09 09 09 20 20 20 20 20 20 20 exn)....
3e60: 28 62 65 67 69 6e 0a 09 09 09 09 20 28 70 70 20 (begin..... (pp
3e70: 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 (condition->list
3e80: 20 65 78 6e 29 20 2a 64 65 66 61 75 6c 74 2d 6c exn) *default-l
3e90: 6f 67 2d 70 6f 72 74 2a 29 0a 09 09 09 09 20 28 og-port*)..... (
3ea0: 70 70 20 64 61 74 20 2a 64 65 66 61 75 6c 74 2d pp dat *default-
3eb0: 6c 6f 67 2d 70 6f 72 74 2a 29 0a 09 09 09 09 20 log-port*).....
3ec0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
3ed0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3ee0: 2a 20 6d 73 67 0a 09 09 09 09 09 20 20 20 20 20 * msg......
3ef0: 20 22 2c 20 65 72 72 6f 72 3a 20 22 20 20 20 20 ", error: "
3f00: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
3f10: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
3f20: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 20 20 exn 'message)
3f30: 65 78 6e 29 0a 09 09 09 09 09 20 20 20 20 20 20 exn)......
3f40: 22 2c 20 61 72 67 75 6d 65 6e 74 73 3a 20 22 20 ", arguments: "
3f50: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
3f60: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
3f70: 78 6e 20 27 61 72 67 75 6d 65 6e 74 73 29 20 65 xn 'arguments) e
3f80: 78 6e 29 0a 09 09 09 09 09 20 20 20 20 20 20 22 xn)...... "
3f90: 2c 20 6c 6f 63 61 74 69 6f 6e 3a 20 22 20 20 28 , location: " (
3fa0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
3fb0: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
3fc0: 6e 20 27 6c 6f 63 61 74 69 6f 6e 29 20 20 65 78 n 'location) ex
3fd0: 6e 29 0a 09 09 09 09 09 20 20 20 20 20 20 29 29 n)...... ))
3fe0: 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
3ff0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
4000: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 6d 73 67 lt-log-port* msg
4010: 20 22 28 6e 6f 74 65 3a 20 65 78 6e 3d 22 65 78 "(note: exn="ex
4020: 6e 22 2c 20 69 73 20 6e 6f 74 20 61 20 63 6f 6e n", is not a con
4030: 64 69 74 69 6f 6e 20 6f 62 6a 65 63 74 2e 22 29 dition object.")
4040: 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 69 74 )))). (condit
4050: 69 6f 6e 2d 63 61 73 65 0a 20 20 20 20 20 28 6c ion-case. (l
4060: 65 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 et-values (((inp
4070: 20 6f 75 70 29 28 74 63 70 2d 63 6f 6e 6e 65 63 oup)(tcp-connec
4080: 74 20 68 6f 73 74 20 70 6f 72 74 29 29 29 0a 20 t host port))).
4090: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
40a0: 20 28 69 66 20 28 61 6e 64 20 69 6e 70 20 6f 75 (if (and inp ou
40b0: 70 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 p)... (begi
40c0: 6e 0a 09 09 09 28 73 65 72 69 61 6c 69 7a 65 20 n....(serialize
40d0: 64 61 74 20 6f 75 70 29 0a 09 09 09 28 63 6c 6f dat oup)....(clo
40e0: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f se-output-port o
40f0: 75 70 29 0a 09 09 09 28 64 65 73 65 72 69 61 6c up)....(deserial
4100: 69 7a 65 20 69 6e 70 29 29 0a 09 09 20 20 20 20 ize inp))...
4110: 20 20 29 29 29 0a 09 20 28 63 6c 6f 73 65 2d 69 ))).. (close-i
4120: 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 09 nput-port inp)..
4130: 20 28 6d 61 74 63 68 20 72 65 73 0a 09 20 20 20 (match res..
4140: 28 28 72 65 73 75 6c 74 20 65 78 6e 2d 72 65 73 ((result exn-res
4150: 75 6c 74 20 73 74 64 6f 75 74 2d 72 65 73 75 6c ult stdout-resul
4160: 74 29 0a 09 20 20 20 20 28 69 66 20 65 78 6e 2d t).. (if exn-
4170: 72 65 73 75 6c 74 0a 09 09 28 66 75 6c 6c 2d 65 result...(full-e
4180: 72 72 2d 70 72 69 6e 74 20 65 78 6e 2d 72 65 73 rr-print exn-res
4190: 75 6c 74 20 22 45 52 52 4f 52 3a 20 53 65 72 76 ult "ERROR: Serv
41a0: 65 72 20 73 69 64 65 20 65 78 63 65 70 74 69 6f er side exceptio
41b0: 6e 20 64 65 74 65 63 74 65 64 22 29 29 0a 09 20 n detected"))..
41c0: 20 20 20 28 69 66 20 73 74 64 6f 75 74 2d 72 65 (if stdout-re
41d0: 73 75 6c 74 0a 09 09 28 64 65 62 75 67 3a 70 72 sult...(debug:pr
41e0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
41f0: 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
4200: 20 4f 75 74 70 75 74 20 64 65 74 65 63 74 65 64 Output detected
4210: 20 6f 6e 20 73 74 64 6f 75 74 20 6f 6e 20 73 65 on stdout on se
4220: 72 76 65 72 20 73 69 64 65 20 65 78 65 63 75 74 rver side execut
4230: 69 6f 6e 20 3d 3e 20 22 73 74 64 6f 75 74 2d 72 ion => "stdout-r
4240: 65 73 75 6c 74 29 29 0a 09 20 20 20 20 72 65 73 esult)).. res
4250: 75 6c 74 29 0a 09 20 20 20 28 65 6c 73 65 0a 09 ult).. (else..
4260: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4270: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
4280: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 73 65 port* "ERROR: se
4290: 72 76 65 72 20 72 65 74 75 72 6e 65 64 20 6e 6f rver returned no
42a0: 6e 2d 73 74 61 6e 64 61 72 64 20 6f 75 74 70 75 n-standard outpu
42b0: 74 3a 20 22 72 65 73 29 0a 09 20 20 20 20 23 66 t: "res).. #f
42c0: 29 29 29 29 0a 20 20 20 20 20 28 65 78 6e 20 28 )))). (exn (
42d0: 69 6f 2d 65 72 72 6f 72 29 0a 09 20 20 28 66 75 io-error).. (fu
42e0: 6c 6c 2d 65 72 72 2d 70 72 69 6e 74 20 65 78 6e ll-err-print exn
42f0: 20 20 22 45 52 52 4f 52 3a 20 69 2f 6f 20 65 72 "ERROR: i/o er
4300: 72 6f 72 22 29 0a 09 20 20 28 74 74 3a 62 61 63 ror").. (tt:bac
4310: 6b 6f 66 66 2d 69 6e 63 72 20 68 6f 73 74 20 70 koff-incr host p
4320: 6f 72 74 29 0a 09 20 20 23 66 29 0a 20 20 20 20 ort).. #f).
4330: 20 28 65 78 6e 20 28 69 2f 6f 20 6e 65 74 29 0a (exn (i/o net).
4340: 09 20 20 28 69 66 20 70 69 6e 67 2d 6d 6f 64 65 . (if ping-mode
4350: 0a 09 20 20 20 20 20 20 23 66 0a 09 20 20 20 20 .. #f..
4360: 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 20 20 (cond..
4370: 28 28 3e 20 20 74 72 69 65 73 2d 72 65 6d 61 69 ((> tries-remai
4380: 6e 69 6e 67 20 34 29 20 3b 3b 20 73 65 72 76 65 ning 4) ;; serve
4390: 72 20 6c 69 6b 65 6c 79 20 64 65 66 75 6e 63 74 r likely defunct
43a0: 0a 09 09 28 74 74 3a 62 61 63 6b 6f 66 66 2d 69 ...(tt:backoff-i
43b0: 6e 63 72 20 68 6f 73 74 20 70 6f 72 74 29 0a 09 ncr host port)..
43c0: 09 23 66 29 0a 09 20 20 20 20 20 20 20 28 28 3e .#f).. ((>
43d0: 3d 20 74 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e = tries-remainin
43e0: 67 20 30 29 0a 09 09 28 6c 65 74 2a 20 28 28 62 g 0)...(let* ((b
43f0: 61 63 6b 6f 66 66 2d 64 65 6c 61 79 20 28 6d 61 ackoff-delay (ma
4400: 78 20 28 2a 20 28 2d 20 32 36 20 74 72 69 65 73 x (* (- 26 tries
4410: 2d 72 65 6d 61 69 6e 69 6e 67 29 20 30 2e 31 29 -remaining) 0.1)
4420: 20 31 2e 30 29 29 29 0a 09 09 20 20 28 64 65 62 1.0)))... (deb
4430: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
4440: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
4450: 41 52 4e 49 4e 47 3a 20 54 43 50 20 6f 76 65 72 ARNING: TCP over
4460: 6c 6f 61 64 2c 20 74 72 79 69 6e 67 20 61 67 61 load, trying aga
4470: 69 6e 20 69 6e 20 22 62 61 63 6b 6f 66 66 2d 64 in in "backoff-d
4480: 65 6c 61 79 22 73 2e 22 29 0a 09 09 20 20 28 74 elay"s.")... (t
4490: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 62 61 63 hread-sleep! bac
44a0: 6b 6f 66 66 2d 64 65 6c 61 79 29 0a 09 09 20 20 koff-delay)...
44b0: 28 74 74 3a 62 61 63 6b 6f 66 66 2d 69 6e 63 72 (tt:backoff-incr
44c0: 20 68 6f 73 74 20 70 6f 72 74 29 0a 09 09 20 20 host port)...
44d0: 28 72 65 74 72 79 29 29 0a 09 09 3b 3b 20 28 61 (retry))...;; (a
44e0: 73 73 65 72 74 20 23 66 20 22 46 41 54 41 4c 3a ssert #f "FATAL:
44f0: 20 54 6f 6f 20 6d 61 6e 79 20 72 65 74 72 69 65 Too many retrie
4500: 73 20 69 6e 20 74 74 3a 73 65 6e 64 2d 72 65 63 s in tt:send-rec
4510: 65 69 76 65 2d 64 69 72 65 63 74 22 29 0a 09 09 eive-direct")...
4520: 29 0a 09 20 20 20 20 20 20 20 28 65 6c 73 65 20 ).. (else
4530: 23 66 29 29 29 29 0a 20 20 20 20 20 28 65 78 6e #f)))). (exn
4540: 20 28 29 0a 09 20 20 28 66 75 6c 6c 2d 65 72 72 ().. (full-err
4550: 2d 70 72 69 6e 74 20 65 78 6e 20 22 55 6e 68 61 -print exn "Unha
4560: 6e 64 6c 65 64 20 65 78 63 65 70 74 69 6f 6e 20 ndled exception
4570: 66 72 6f 6d 20 63 6c 69 65 6e 74 20 73 69 64 65 from client side
4580: 2e 22 29 0a 09 20 20 23 66 29 29 29 29 0a 0a 0a .").. #f))))...
4590: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
45a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 73 65 72 76 ========.;; serv
45e0: 65 72 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d er.;;===========
45f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
4630: 66 69 6e 65 20 28 74 74 3a 73 79 6e 63 2d 64 62 fine (tt:sync-db
4640: 73 20 74 74 64 61 74 29 0a 20 20 23 66 29 0a 0a s ttdat). #f)..
4650: 3b 3b 20 73 74 61 72 74 20 74 68 65 20 6c 69 73 ;; start the lis
4660: 74 65 6e 65 72 20 61 6e 64 20 73 74 61 72 74 20 tener and start
4670: 72 65 73 70 6f 6e 64 69 6e 67 20 74 6f 20 72 65 responding to re
4680: 71 75 65 73 74 73 0a 3b 3b 0a 3b 3b 20 4e 4f 54 quests.;;.;; NOT
4690: 45 3a 20 6f 72 67 61 6e 69 73 65 20 62 79 20 64 E: organise by d
46a0: 62 66 6e 61 6d 65 2c 20 6e 6f 74 20 72 75 6e 2d bfname, not run-
46b0: 69 64 20 73 6f 20 77 65 20 64 6f 6e 27 74 20 6e id so we don't n
46c0: 65 65 64 0a 3b 3b 20 20 20 20 20 20 20 74 6f 20 eed.;; to
46d0: 70 75 6c 6c 20 69 6e 20 6d 6f 72 65 20 6d 6f 64 pull in more mod
46e0: 75 6c 65 73 0a 3b 3b 0a 3b 3b 20 54 68 69 73 20 ules.;;.;; This
46f0: 69 73 20 74 68 65 20 72 6f 75 74 69 6e 65 20 63 is the routine c
4700: 61 6c 6c 65 64 20 69 6e 20 6d 65 67 61 74 65 73 alled in megates
4710: 74 2e 73 63 6d 20 74 6f 20 73 74 61 72 74 20 61 t.scm to start a
4720: 20 73 65 72 76 65 72 0a 3b 3b 0a 3b 3b 20 53 65 server.;;.;; Se
4730: 72 76 65 72 20 76 69 61 62 69 6c 69 74 79 20 69 rver viability i
4740: 73 20 63 68 65 63 6b 65 64 20 69 6e 20 6b 65 65 s checked in kee
4750: 70 2d 72 75 6e 6e 69 6e 67 2e 20 42 6c 69 6e 64 p-running. Blind
4760: 6c 79 20 73 74 61 72 74 20 61 6e 64 20 72 75 6e ly start and run
4770: 20 68 65 72 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e here..;;.(defin
4780: 65 20 28 74 74 3a 73 74 61 72 74 2d 73 65 72 76 e (tt:start-serv
4790: 65 72 20 61 72 65 61 70 61 74 68 20 72 75 6e 2d er areapath run-
47a0: 69 64 20 64 62 66 6e 61 6d 65 2d 69 6e 20 68 61 id dbfname-in ha
47b0: 6e 64 6c 65 72 20 6b 65 79 73 29 0a 20 20 28 61 ndler keys). (a
47c0: 73 73 65 72 74 20 61 72 65 61 70 61 74 68 20 22 ssert areapath "
47d0: 46 41 54 41 4c 3a 20 61 72 65 61 70 61 74 68 20 FATAL: areapath
47e0: 6e 6f 74 20 70 72 6f 76 69 64 65 64 20 66 6f 72 not provided for
47f0: 20 74 74 3a 73 74 61 72 74 2d 73 65 72 76 65 72 tt:start-server
4800: 22 29 0a 20 20 3b 3b 20 69 73 20 74 68 65 72 65 "). ;; is there
4810: 20 61 6c 72 65 61 64 79 20 61 20 73 65 72 76 65 already a serve
4820: 72 20 66 6f 72 20 74 68 69 73 20 64 62 66 69 6c r for this dbfil
4830: 65 3f 20 54 68 65 6e 20 65 78 69 74 2e 0a 20 20 e? Then exit..
4840: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a (debug:print 2 *
4850: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4860: 2a 20 22 74 74 3a 73 74 61 72 74 2d 73 65 72 76 * "tt:start-serv
4870: 65 72 3a 20 22 20 64 62 66 6e 61 6d 65 2d 69 6e er: " dbfname-in
4880: 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 74 64 61 ). (let* ((ttda
4890: 74 20 20 20 28 6d 61 6b 65 2d 74 74 20 61 72 65 t (make-tt are
48a0: 61 70 61 74 68 3a 20 61 72 65 61 70 61 74 68 29 apath: areapath)
48b0: 29 0a 09 20 28 64 62 66 6e 61 6d 65 20 28 6f 72 ).. (dbfname (or
48c0: 20 64 62 66 6e 61 6d 65 2d 69 6e 20 28 64 62 6d dbfname-in (dbm
48d0: 6f 64 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 6e 61 od:run-id->dbfna
48e0: 6d 65 20 72 75 6e 2d 69 64 29 29 29 0a 09 20 28 me run-id))).. (
48f0: 73 65 72 76 65 72 73 20 28 74 74 3a 66 69 6e 64 servers (tt:find
4900: 2d 73 65 72 76 65 72 20 61 72 65 61 70 61 74 68 -server areapath
4910: 20 64 62 66 6e 61 6d 65 29 29 29 20 3b 3b 20 73 dbfname))) ;; s
4920: 68 6f 75 6c 64 20 75 73 65 20 74 74 3a 67 65 74 hould use tt:get
4930: 2d 63 75 72 72 65 6e 74 2d 73 65 72 76 65 72 2d -current-server-
4940: 69 6e 66 6f 20 69 6e 73 74 65 61 64 0a 20 20 20 info instead.
4950: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
4960: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
4970: 67 2d 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 22 g-port* "Found "
4980: 20 28 6c 65 6e 67 74 68 20 73 65 72 76 65 72 73 (length servers
4990: 29 20 22 20 61 6c 72 65 61 64 79 20 72 75 6e 6e ) " already runn
49a0: 69 6e 67 20 66 6f 72 20 22 20 64 62 66 6e 61 6d ing for " dbfnam
49b0: 65 29 0a 20 20 20 20 28 69 66 20 28 3e 20 28 6c e). (if (> (l
49c0: 65 6e 67 74 68 20 73 65 72 76 65 72 73 29 20 30 ength servers) 0
49d0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
49e0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
49f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4a00: 49 4e 46 4f 3a 20 66 6f 75 6e 64 20 73 65 72 76 INFO: found serv
4a10: 65 72 28 73 29 20 61 6c 72 65 61 64 79 20 72 75 er(s) already ru
4a20: 6e 6e 69 6e 67 20 66 6f 72 20 64 62 20 22 64 62 nning for db "db
4a30: 66 6e 61 6d 65 22 2c 20 22 28 73 74 72 69 6e 67 fname", "(string
4a40: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 73 65 72 -intersperse ser
4a50: 76 65 72 73 20 22 2c 22 29 22 20 45 78 69 74 69 vers ",")" Exiti
4a60: 6e 67 2e 22 29 0a 09 20 20 28 65 78 69 74 29 29 ng.").. (exit))
4a70: 0a 09 28 6c 65 74 2a 20 28 28 64 62 73 74 72 75 ..(let* ((dbstru
4a80: 63 74 20 20 20 28 64 62 6d 6f 64 3a 6f 70 65 6e ct (dbmod:open
4a90: 2d 64 62 6d 6f 64 64 62 20 61 72 65 61 70 61 74 -dbmoddb areapat
4aa0: 68 20 72 75 6e 2d 69 64 20 64 62 66 6e 61 6d 65 h run-id dbfname
4ab0: 20 28 64 62 66 69 6c 65 3a 64 62 2d 69 6e 69 74 (dbfile:db-init
4ac0: 2d 70 72 6f 63 29 20 6b 65 79 73 29 29 29 0a 09 -proc) keys)))..
4ad0: 20 20 28 74 74 2d 68 61 6e 64 6c 65 72 2d 73 65 (tt-handler-se
4ae0: 74 21 20 74 74 64 61 74 20 28 68 61 6e 64 6c 65 t! ttdat (handle
4af0: 72 20 64 62 73 74 72 75 63 74 29 29 0a 09 20 20 r dbstruct))..
4b00: 28 6c 65 74 2a 20 28 28 74 63 70 2d 74 68 72 65 (let* ((tcp-thre
4b10: 61 64 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a ad (make-thread.
4b20: 09 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ... (lambda
4b30: 20 28 29 0a 09 09 09 09 28 74 74 3a 73 74 61 72 ().....(tt:star
4b40: 74 2d 74 63 70 2d 73 65 72 76 65 72 20 74 74 64 t-tcp-server ttd
4b50: 61 74 29 29 20 3b 3b 20 73 74 61 72 74 20 74 68 at)) ;; start th
4b60: 65 20 74 63 70 2d 73 65 72 76 65 72 20 77 68 69 e tcp-server whi
4b70: 63 68 20 61 70 70 6c 69 65 73 20 68 61 6e 64 6c ch applies handl
4b80: 65 72 20 74 6f 20 69 6e 63 6f 6d 69 6e 67 20 64 er to incoming d
4b90: 61 74 61 0a 09 09 09 20 20 20 20 20 20 22 74 63 ata.... "tc
4ba0: 70 2d 73 65 72 76 65 72 2d 74 68 72 65 61 64 22 p-server-thread"
4bb0: 29 29 0a 09 09 20 28 72 75 6e 2d 74 68 72 65 61 ))... (run-threa
4bc0: 64 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 d (make-thread..
4bd0: 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
4be0: 28 29 0a 09 09 09 09 28 74 74 3a 6b 65 65 70 2d ().....(tt:keep-
4bf0: 72 75 6e 6e 69 6e 67 20 74 74 64 61 74 20 64 62 running ttdat db
4c00: 66 6e 61 6d 65 20 64 62 73 74 72 75 63 74 29 29 fname dbstruct))
4c10: 29 29 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 ))).. (thread
4c20: 2d 73 74 61 72 74 21 20 74 63 70 2d 74 68 72 65 -start! tcp-thre
4c30: 61 64 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 ad).. (thread
4c40: 2d 73 74 61 72 74 21 20 72 75 6e 2d 74 68 72 65 -start! run-thre
4c50: 61 64 29 0a 0a 09 20 20 20 20 28 6c 65 74 2a 20 ad)... (let*
4c60: 28 28 61 72 65 61 70 61 74 68 20 20 20 20 20 28 ((areapath (
4c70: 74 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 61 tt-areapath ttda
4c80: 74 29 29 0a 09 09 20 20 20 28 6e 6f 73 79 6e 63 t))... (nosync
4c90: 64 62 70 61 74 68 20 28 63 6f 6e 63 20 61 72 65 dbpath (conc are
4ca0: 61 70 61 74 68 22 2f 2e 6d 74 64 62 22 29 29 29 apath"/.mtdb")))
4cb0: 0a 09 20 20 20 20 20 20 3b 3b 20 74 68 69 73 20 .. ;; this
4cc0: 64 69 64 6e 27 74 20 73 65 65 6d 20 74 6f 20 77 didn't seem to w
4cd0: 6f 72 6b 2c 20 69 73 20 70 6f 72 74 20 6e 6f 74 ork, is port not
4ce0: 20 61 76 61 69 6c 61 62 6c 65 20 79 65 74 3f 0a available yet?.
4cf0: 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 . (let loop
4d00: 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 09 09 28 ((count 0))...(
4d10: 69 66 20 28 74 74 2d 70 6f 72 74 20 74 74 64 61 if (tt-port ttda
4d20: 74 29 0a 09 09 20 20 20 20 28 62 65 67 69 6e 0a t)... (begin.
4d30: 09 09 20 20 20 20 20 20 28 70 72 6f 63 69 6e 66 .. (procinf
4d40: 2d 70 6f 72 74 2d 73 65 74 21 20 2a 70 72 6f 63 -port-set! *proc
4d50: 69 6e 66 2a 20 28 74 74 2d 70 6f 72 74 20 74 74 inf* (tt-port tt
4d60: 64 61 74 29 29 0a 09 09 20 20 20 20 20 20 28 70 dat))... (p
4d70: 72 6f 63 69 6e 66 2d 64 62 6e 61 6d 65 2d 73 65 rocinf-dbname-se
4d80: 74 21 20 2a 70 72 6f 63 69 6e 66 2a 20 64 62 66 t! *procinf* dbf
4d90: 6e 61 6d 65 29 0a 09 09 20 20 20 20 20 20 28 64 name)... (d
4da0: 62 66 69 6c 65 3a 77 69 74 68 2d 6e 6f 2d 73 79 bfile:with-no-sy
4db0: 6e 63 2d 64 62 0a 09 09 20 20 20 20 20 20 20 6e nc-db... n
4dc0: 6f 73 79 6e 63 64 62 70 61 74 68 0a 09 09 20 20 osyncdbpath...
4dd0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6e 73 (lambda (ns
4de0: 64 62 29 0a 09 09 09 20 28 64 62 66 69 6c 65 3a db).... (dbfile:
4df0: 69 6e 73 65 72 74 2d 6f 72 2d 75 70 64 61 74 65 insert-or-update
4e00: 2d 70 72 6f 63 65 73 73 20 6e 73 64 62 20 2a 70 -process nsdb *p
4e10: 72 6f 63 69 6e 66 2a 29 29 29 29 0a 09 09 20 20 rocinf*))))...
4e20: 20 20 28 69 66 20 28 3c 20 63 6f 75 6e 74 20 35 (if (< count 5
4e30: 29 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 )....(begin....
4e40: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
4e50: 30 2e 35 29 0a 09 09 09 20 20 28 6c 6f 6f 70 20 0.5).... (loop
4e60: 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 (+ count 1)))...
4e70: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
4e80: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
4e90: 74 2a 20 22 45 52 52 4f 52 3a 20 28 74 74 2d 70 t* "ERROR: (tt-p
4ea0: 6f 72 74 20 74 74 64 61 74 29 20 6e 6f 20 70 6f ort ttdat) no po
4eb0: 72 74 20 73 65 74 21 22 29 29 29 29 0a 09 20 20 rt set!"))))..
4ec0: 20 20 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 .. (threa
4ed0: 64 2d 6a 6f 69 6e 21 20 72 75 6e 2d 74 68 72 65 d-join! run-thre
4ee0: 61 64 29 20 3b 3b 20 72 75 6e 20 74 68 72 65 61 ad) ;; run threa
4ef0: 64 20 77 69 6c 6c 20 65 78 69 74 20 6f 6e 20 74 d will exit on t
4f00: 69 6d 65 6f 75 74 20 6f 72 20 6f 74 68 65 72 20 imeout or other
4f10: 63 6f 6e 64 69 74 69 6f 6e 73 0a 09 20 20 20 20 conditions..
4f20: 20 20 3b 3b 20 72 65 70 6c 61 63 65 20 77 69 74 ;; replace wit
4f30: 68 20 63 61 6c 6c 20 74 6f 20 28 64 62 66 69 6c h call to (dbfil
4f40: 65 3a 73 65 74 2d 70 72 6f 63 65 73 73 2d 64 6f e:set-process-do
4f50: 6e 65 20 6e 73 64 62 20 68 6f 73 74 20 70 69 64 ne nsdb host pid
4f60: 20 72 65 61 73 6f 6e 29 0a 09 20 20 20 20 20 20 reason)..
4f70: 28 70 72 6f 63 69 6e 66 2d 73 74 61 74 75 73 2d (procinf-status-
4f80: 73 65 74 21 20 2a 70 72 6f 63 69 6e 66 2a 20 22 set! *procinf* "
4f90: 64 6f 6e 65 22 29 0a 09 20 20 20 20 20 20 28 70 done").. (p
4fa0: 72 6f 63 69 6e 66 2d 65 6e 64 2d 73 65 74 21 20 rocinf-end-set!
4fb0: 2a 70 72 6f 63 69 6e 66 2a 20 28 63 75 72 72 65 *procinf* (curre
4fc0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 nt-seconds))..
4fd0: 20 20 20 20 28 64 62 66 69 6c 65 3a 77 69 74 68 (dbfile:with
4fe0: 2d 6e 6f 2d 73 79 6e 63 2d 64 62 0a 09 20 20 20 -no-sync-db..
4ff0: 20 20 20 20 6e 6f 73 79 6e 63 64 62 70 61 74 68 nosyncdbpath
5000: 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
5010: 20 28 6e 73 64 62 29 0a 09 09 20 28 64 62 66 69 (nsdb)... (dbfi
5020: 6c 65 3a 69 6e 73 65 72 74 2d 6f 72 2d 75 70 64 le:insert-or-upd
5030: 61 74 65 2d 70 72 6f 63 65 73 73 20 6e 73 64 62 ate-process nsdb
5040: 20 2a 70 72 6f 63 69 6e 66 2a 29 29 29 0a 20 20 *procinf*))).
5050: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
5060: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
5070: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
5080: 78 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 20 xiting now.")..
5090: 20 20 20 20 20 28 65 78 69 74 29 29 29 29 29 29 (exit))))))
50a0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 6b )..(define (tt:k
50b0: 65 65 70 2d 72 75 6e 6e 69 6e 67 20 74 74 64 61 eep-running ttda
50c0: 74 20 64 62 66 6e 61 6d 65 20 64 62 73 74 72 75 t dbfname dbstru
50d0: 63 74 29 0a 20 20 3b 3b 20 76 65 72 66 69 79 20 ct). ;; verfiy
50e0: 63 6f 6e 6e 20 66 6f 72 20 72 65 61 64 79 0a 20 conn for ready.
50f0: 20 3b 3b 20 6c 69 73 74 65 6e 65 72 20 73 6f 63 ;; listener soc
5100: 6b 65 74 20 68 61 73 20 62 65 65 6e 20 73 74 61 ket has been sta
5110: 72 74 65 64 20 62 79 20 74 68 69 73 20 73 74 61 rted by this sta
5120: 67 65 0a 20 20 3b 3b 20 77 61 69 74 20 66 6f 72 ge. ;; wait for
5130: 20 61 20 70 6f 72 74 20 62 65 66 6f 72 65 20 63 a port before c
5140: 72 65 61 74 69 6e 67 20 74 68 65 20 72 65 67 69 reating the regi
5150: 73 74 72 61 74 69 6f 6e 20 66 69 6c 65 0a 20 20 stration file.
5160: 3b 3b 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 2d ;;. (let* ((db-
5170: 6c 6f 63 6b 65 64 2d 69 6e 20 23 66 29 0a 09 20 locked-in #f)..
5180: 28 61 72 65 61 70 61 74 68 20 20 20 20 20 28 74 (areapath (t
5190: 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 61 74 t-areapath ttdat
51a0: 29 29 0a 09 20 28 6e 6f 73 79 6e 63 64 62 70 61 )).. (nosyncdbpa
51b0: 74 68 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 th (conc areapat
51c0: 68 22 2f 2e 6d 74 64 62 22 29 29 0a 09 20 28 63 h"/.mtdb")).. (c
51d0: 6c 65 61 6e 75 70 20 28 6c 61 6d 62 64 61 20 28 leanup (lambda (
51e0: 29 0a 09 09 20 20 20 20 28 69 66 20 28 74 74 2d )... (if (tt-
51f0: 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 74 74 64 cleanup-proc ttd
5200: 61 74 29 0a 09 09 09 28 28 74 74 2d 63 6c 65 61 at)....((tt-clea
5210: 6e 75 70 2d 70 72 6f 63 20 74 74 64 61 74 29 29 nup-proc ttdat))
5220: 29 0a 09 09 20 20 20 20 28 64 62 66 69 6c 65 3a )... (dbfile:
5230: 77 69 74 68 2d 6e 6f 2d 73 79 6e 63 2d 64 62 20 with-no-sync-db
5240: 6e 6f 73 79 6e 63 64 62 70 61 74 68 0a 09 09 09 nosyncdbpath....
5250: 09 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 .. (lambda (d
5260: 62 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 6c b)...... (l
5270: 65 74 2a 20 28 28 64 62 74 6d 70 6e 61 6d 65 20 et* ((dbtmpname
5280: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 64 62 (dbr:dbstruct-db
5290: 74 6d 70 6e 61 6d 65 20 64 62 73 74 72 75 63 74 tmpname dbstruct
52a0: 29 29 29 0a 09 09 09 09 09 09 28 64 65 62 75 67 ))).......(debug
52b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
52c0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
52d0: 20 22 52 75 6e 6e 69 6e 67 20 63 6c 65 61 6e 20 "Running clean
52e0: 75 70 2c 20 69 6e 63 6c 75 64 69 6e 67 20 72 65 up, including re
52f0: 6d 6f 76 69 6e 67 20 64 62 20 66 69 6c 65 20 22 moving db file "
5300: 64 62 74 6d 70 6e 61 6d 65 29 0a 09 09 09 09 09 dbtmpname)......
5310: 09 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c .(db:no-sync-del
5320: 21 20 64 62 20 64 62 66 6e 61 6d 65 29 0a 20 20 ! db dbfname).
5330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 ))
5360: 29 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a )))). (set! *
5370: 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 74 74 64 server-info* ttd
5380: 61 74 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f at). (let loo
5390: 70 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 p ((count 0)).
53a0: 20 20 20 20 28 69 66 20 28 3e 20 63 6f 75 6e 74 (if (> count
53b0: 20 32 34 30 29 0a 09 20 20 28 62 65 67 69 6e 0a 240).. (begin.
53c0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
53d0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
53e0: 2d 70 6f 72 74 2a 20 22 46 41 54 41 4c 3a 20 43 -port* "FATAL: C
53f0: 6f 75 6c 64 20 6e 6f 74 20 73 74 61 72 74 20 61 ould not start a
5400: 20 74 63 70 20 73 65 72 76 65 72 2c 20 67 69 76 tcp server, giv
5410: 69 6e 67 20 75 70 2e 22 29 0a 09 20 20 20 20 28 ing up.").. (
5420: 65 78 69 74 20 31 29 29 0a 09 20 20 28 69 66 20 exit 1)).. (if
5430: 28 6e 6f 74 20 28 74 74 2d 70 6f 72 74 20 74 74 (not (tt-port tt
5440: 64 61 74 29 29 20 3b 3b 20 6e 6f 20 63 6f 6e 6e dat)) ;; no conn
5450: 65 63 74 69 6f 6e 20 79 65 74 0a 09 20 20 20 20 ection yet..
5460: 20 20 28 62 65 67 69 6e 0a 09 09 28 74 68 72 65 (begin...(thre
5470: 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 0a ad-sleep! 0.25).
5480: 09 09 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 ..(loop (+ count
5490: 20 31 29 29 29 29 29 29 0a 20 20 20 20 0a 20 20 1)))))). .
54a0: 20 20 28 74 74 3a 63 72 65 61 74 65 2d 73 65 72 (tt:create-ser
54b0: 76 65 72 2d 72 65 67 69 73 74 72 61 74 69 6f 6e ver-registration
54c0: 2d 66 69 6c 65 20 74 74 64 61 74 20 64 62 66 6e -file ttdat dbfn
54d0: 61 6d 65 29 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 ame). ;; now
54e0: 73 74 61 72 74 20 77 61 74 63 68 69 6e 67 20 74 start watching t
54f0: 68 65 20 6c 61 73 74 2d 61 63 63 65 73 73 2c 20 he last-access,
5500: 69 66 20 69 74 20 68 61 73 6e 27 74 20 62 65 65 if it hasn't bee
5510: 6e 20 74 6f 75 63 68 65 64 0a 20 20 20 20 3b 3b n touched. ;;
5520: 20 69 6e 20 6f 76 65 72 20 74 65 6e 20 73 65 63 in over ten sec
5530: 6f 6e 64 73 20 77 65 20 65 78 69 74 0a 20 20 20 onds we exit.
5540: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
5550: 30 2e 30 35 29 20 3b 3b 20 61 6e 79 20 72 65 61 0.05) ;; any rea
5560: 6c 20 6e 65 65 64 20 66 6f 72 20 64 65 6c 61 79 l need for delay
5570: 20 68 65 72 65 3f 0a 20 20 20 20 28 6c 65 74 20 here?. (let
5580: 6c 6f 6f 70 20 28 29 0a 20 20 20 20 20 20 28 6c loop (). (l
5590: 65 74 2a 20 28 28 73 65 72 76 65 72 73 20 28 74 et* ((servers (t
55a0: 74 3a 67 65 74 2d 73 65 72 76 65 72 2d 69 6e 66 t:get-server-inf
55b0: 6f 2d 73 6f 72 74 65 64 20 74 74 64 61 74 20 64 o-sorted ttdat d
55c0: 62 66 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 28 bfname)).. (
55d0: 6f 6b 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 ok (cond...
55e0: 20 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 73 ((null? s
55f0: 65 72 76 65 72 73 29 20 23 66 29 20 3b 3b 20 6e ervers) #f) ;; n
5600: 6f 74 20 6f 6b 0a 09 09 20 20 20 20 20 20 20 28 ot ok... (
5610: 28 65 71 75 61 6c 3f 20 28 6c 69 73 74 2d 72 65 (equal? (list-re
5620: 66 20 28 63 61 72 20 73 65 72 76 65 72 73 29 20 f (car servers)
5630: 36 29 20 3b 3b 20 63 6f 6d 70 61 72 65 20 74 68 6) ;; compare th
5640: 65 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 0a 09 e servinfofile..
5650: 09 09 09 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 ...(tt-servinf-f
5660: 69 6c 65 20 74 74 64 61 74 29 29 0a 09 09 09 28 ile ttdat))....(
5670: 6c 65 74 2a 20 28 28 72 65 73 20 28 69 66 20 64 let* ((res (if d
5680: 62 2d 6c 6f 63 6b 65 64 2d 69 6e 0a 09 09 09 09 b-locked-in.....
5690: 09 23 74 0a 09 09 09 09 09 28 6c 65 74 2a 20 28 .#t......(let* (
56a0: 28 6c 6f 63 6b 2d 72 65 73 75 6c 74 20 20 3b 3b (lock-result ;;
56b0: 20 74 68 69 73 20 69 73 20 74 68 65 20 70 72 69 this is the pri
56c0: 6d 61 72 79 20 6c 6f 63 6b 20 2d 20 6e 65 65 64 mary lock - need
56d0: 20 74 6f 20 64 6f 75 62 6c 65 20 76 65 72 69 66 to double verif
56e0: 79 20 74 68 61 74 20 67 6f 74 20 69 74 0a 09 09 y that got it...
56f0: 09 09 09 09 28 64 62 66 69 6c 65 3a 77 69 74 68 ....(dbfile:with
5700: 2d 6e 6f 2d 73 79 6e 63 2d 64 62 0a 09 09 09 09 -no-sync-db.....
5710: 09 09 20 6e 6f 73 79 6e 63 64 62 70 61 74 68 0a .. nosyncdbpath.
5720: 09 09 09 09 09 09 20 28 6c 61 6d 62 64 61 20 28 ...... (lambda (
5730: 64 62 29 0a 09 09 09 09 09 09 20 20 20 28 64 62 db)....... (db
5740: 3a 6e 6f 2d 73 79 6e 63 2d 6c 6f 63 6b 2d 61 6e :no-sync-lock-an
5750: 64 2d 63 68 65 63 6b 20 64 62 20 64 62 66 6e 61 d-check db dbfna
5760: 6d 65 0a 09 09 09 09 09 09 09 09 09 20 20 20 20 me..........
5770: 20 20 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 69 (tt-servinf-fi
5780: 6c 65 20 74 74 64 61 74 29 0a 09 09 09 09 09 09 le ttdat).......
5790: 09 09 09 20 20 20 20 20 20 3b 3b 20 28 64 62 72 ... ;; (dbr
57a0: 3a 64 62 73 74 72 75 63 74 2d 64 62 74 6d 70 6e :dbstruct-dbtmpn
57b0: 61 6d 65 20 64 62 73 74 72 75 63 74 29 0a 09 09 ame dbstruct)...
57c0: 09 09 09 09 09 09 09 20 20 20 20 20 20 29 29 29 ....... )))
57d0: 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 73 )...... (s
57e0: 75 63 63 65 73 73 20 28 63 61 72 20 6c 6f 63 6b uccess (car lock
57f0: 2d 72 65 73 75 6c 74 29 29 29 0a 09 09 09 09 09 -result)))......
5800: 20 20 28 69 66 20 73 75 63 63 65 73 73 0a 09 09 (if success...
5810: 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ... (begin.
5820: 09 09 09 09 09 09 28 74 74 2d 73 74 61 74 65 2d ......(tt-state-
5830: 73 65 74 21 20 74 74 64 61 74 20 27 72 75 6e 6e set! ttdat 'runn
5840: 69 6e 67 29 0a 09 09 09 09 09 09 28 64 65 62 75 ing).......(debu
5850: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
5860: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 47 6f lt-log-port* "Go
5870: 74 20 73 65 72 76 65 72 20 6c 6f 63 6b 20 66 6f t server lock fo
5880: 72 20 22 20 64 62 66 6e 61 6d 65 29 0a 09 09 09 r " dbfname)....
5890: 09 09 09 28 73 65 74 21 20 64 62 2d 6c 6f 63 6b ...(set! db-lock
58a0: 65 64 2d 69 6e 20 23 74 29 0a 09 09 09 09 09 09 ed-in #t).......
58b0: 23 74 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 #t)...... (
58c0: 62 65 67 69 6e 0a 09 09 09 09 09 09 28 64 65 62 begin.......(deb
58d0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
58e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 ult-log-port* "F
58f0: 61 69 6c 65 64 20 74 6f 20 67 65 74 20 73 65 72 ailed to get ser
5900: 76 65 72 20 6c 6f 63 6b 20 66 6f 72 20 22 64 62 ver lock for "db
5910: 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 23 66 29 fname).......#f)
5920: 29 29 29 29 29 0a 09 09 09 20 20 28 69 66 20 28 ))))).... (if (
5930: 61 6e 64 20 72 65 73 20 28 63 6f 6d 6d 6f 6e 3a and res (common:
5940: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
5950: 31 32 30 20 22 74 6f 70 20 73 65 72 76 65 72 20 120 "top server
5960: 6d 65 73 73 61 67 65 22 29 29 0a 09 09 09 20 20 message"))....
5970: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5980: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5990: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4b 65 65 70 -log-port* "Keep
59a0: 20 72 75 6e 6e 69 6e 67 2c 20 49 27 6d 20 74 68 running, I'm th
59b0: 65 20 74 6f 70 20 73 65 72 76 65 72 20 66 6f 72 e top server for
59c0: 20 22 0a 09 09 09 09 09 09 64 62 66 6e 61 6d 65 ".......dbfname
59d0: 22 20 6f 6e 20 22 28 74 74 2d 68 6f 73 74 20 74 " on "(tt-host t
59e0: 74 64 61 74 29 22 3a 22 28 74 74 2d 70 6f 72 74 tdat)":"(tt-port
59f0: 20 74 74 64 61 74 29 29 29 0a 09 09 09 20 20 72 ttdat))).... r
5a00: 65 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 65 es))... (e
5a10: 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 lse.
5a20: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 77 ;; w
5a30: 72 6f 6e 67 20 73 65 72 76 69 6e 66 6f 20 66 69 rong servinfo fi
5a40: 6c 65 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 le....(debug:pri
5a50: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
5a60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 27 lt-log-port* "I'
5a70: 6d 20 6e 6f 74 20 74 68 65 20 6c 65 61 64 20 73 m not the lead s
5a80: 65 72 76 65 72 3a 20 22 73 65 72 76 65 72 73 29 erver: "servers)
5a90: 0a 09 09 09 28 6c 65 74 2a 20 28 28 6c 65 61 64 ....(let* ((lead
5aa0: 73 72 76 20 28 63 61 72 20 73 65 72 76 65 72 73 srv (car servers
5ab0: 29 29 29 0a 09 09 09 20 20 28 6d 61 74 63 68 20 ))).... (match
5ac0: 6c 65 61 64 73 72 76 0a 09 09 09 20 20 20 20 28 leadsrv.... (
5ad0: 28 68 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 (host port start
5ae0: 73 65 63 6f 6e 64 73 20 73 65 72 76 65 72 2d 69 seconds server-i
5af0: 64 20 70 69 64 20 64 62 66 6e 61 6d 65 20 73 65 d pid dbfname se
5b00: 72 76 69 6e 66 6f 66 69 6c 65 29 0a 09 09 09 20 rvinfofile)....
5b10: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 73 75 (let* ((resu
5b20: 6c 74 20 20 28 74 74 3a 74 69 6d 65 64 2d 70 69 lt (tt:timed-pi
5b30: 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 73 65 72 ng host port ser
5b40: 76 65 72 2d 69 64 29 29 0a 09 09 09 09 20 20 20 ver-id)).....
5b50: 20 28 72 65 73 20 20 20 20 20 28 63 61 72 20 72 (res (car r
5b60: 65 73 75 6c 74 29 29 0a 09 09 09 09 20 20 20 20 esult)).....
5b70: 28 70 69 6e 67 20 20 20 20 28 63 64 72 20 72 65 (ping (cdr re
5b80: 73 75 6c 74 29 29 29 0a 09 09 09 20 20 20 20 20 sult)))....
5b90: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
5ba0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
5bb0: 6f 67 2d 70 6f 72 74 2a 20 22 50 69 6e 67 20 74 og-port* "Ping t
5bc0: 6f 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 2c o "host":"port",
5bd0: 20 77 69 74 68 20 73 65 72 76 65 72 2d 69 64 20 with server-id
5be0: 22 73 65 72 76 65 72 2d 69 64 0a 09 09 09 09 09 "server-id......
5bf0: 09 20 22 2c 20 61 6e 64 20 66 69 6c 65 20 22 73 . ", and file "s
5c00: 65 72 76 69 6e 66 6f 66 69 6c 65 22 20 72 65 74 ervinfofile" ret
5c10: 75 72 6e 65 64 20 22 72 65 73 29 0a 09 09 09 20 urned "res)....
5c20: 20 20 20 20 20 20 28 69 66 20 72 65 73 0a 09 09 (if res...
5c30: 09 09 20 20 20 23 66 20 3b 3b 20 6e 6f 74 20 74 .. #f ;; not t
5c40: 68 65 20 73 65 72 76 65 72 2c 20 62 75 74 20 61 he server, but a
5c50: 6c 6c 20 67 6f 6f 64 2c 20 77 61 6e 74 20 74 6f ll good, want to
5c60: 20 65 78 69 74 0a 09 09 09 09 20 20 20 28 69 66 exit..... (if
5c70: 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 (and (file-exis
5c80: 74 73 3f 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 ts? servinfofile
5c90: 29 0a 09 09 09 09 09 20 20 28 3e 20 28 2d 20 28 )...... (> (- (
5ca0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
5cb0: 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 (file-modificati
5cc0: 6f 6e 2d 74 69 6d 65 20 73 65 72 76 69 6e 66 6f on-time servinfo
5cd0: 66 69 6c 65 29 29 20 33 30 29 29 0a 09 09 09 09 file)) 30)).....
5ce0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
5cf0: 20 20 20 20 20 20 20 3b 3b 20 63 61 6e 27 74 20 ;; can't
5d00: 70 69 6e 67 20 61 6e 64 20 66 69 6c 65 20 68 61 ping and file ha
5d10: 73 20 62 65 65 6e 20 6f 6e 20 64 69 73 6b 20 31 s been on disk 1
5d20: 35 20 73 65 63 6f 6e 64 73 2c 20 67 6f 20 61 68 5 seconds, go ah
5d30: 65 61 64 20 61 6e 64 20 74 72 79 20 74 6f 20 72 ead and try to r
5d40: 65 6d 6f 76 65 20 69 74 0a 09 09 09 09 20 20 20 emove it.....
5d50: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5d60: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5d70: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 6d 6f -log-port* "Remo
5d80: 76 69 6e 67 20 61 70 70 61 72 65 6e 74 6c 79 20 ving apparently
5d90: 64 65 61 64 20 73 65 72 76 65 72 20 69 6e 66 6f dead server info
5da0: 20 66 69 6c 65 3a 20 22 73 65 72 76 69 6e 66 6f file: "servinfo
5db0: 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 file).
5dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 (ha
5de0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
5df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e10: 20 20 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 exn.
5e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e40: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5e50: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5e60: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 72 72 6f -log-port* "Erro
5e70: 72 20 72 65 6d 6f 76 69 6e 67 20 73 65 72 76 65 r removing serve
5e80: 72 20 69 6e 66 6f 20 66 69 6c 65 3a 20 22 73 65 r info file: "se
5e90: 72 76 69 6e 66 6f 66 69 6c 65 29 0a 09 09 09 09 rvinfofile).....
5ea0: 20 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d (delete-
5eb0: 66 69 6c 65 2a 20 73 65 72 76 69 6e 66 6f 66 69 file* servinfofi
5ec0: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 le).
5ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ee0: 20 20 20 20 20 20 20 20 20 20 20 29 0a 09 09 09 )....
5ef0: 09 20 20 20 20 20 20 20 23 74 29 20 3b 3b 20 6e . #t) ;; n
5f00: 6f 74 20 74 68 65 20 73 65 72 76 65 72 20 62 75 ot the server bu
5f10: 74 20 74 68 65 20 73 65 72 76 65 72 20 69 73 20 t the server is
5f20: 6e 6f 74 20 72 65 61 63 68 61 62 6c 65 0a 09 09 not reachable...
5f30: 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 .. (begin...
5f40: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
5f50: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
5f60: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 27 6d 20 -log-port* "I'm
5f70: 6e 6f 74 20 74 68 65 20 73 65 72 76 65 72 20 62 not the server b
5f80: 75 74 20 63 6f 75 6c 64 20 6e 6f 74 20 70 69 6e ut could not pin
5f90: 67 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 2c g "host":"port",
5fa0: 20 77 69 6c 6c 20 74 72 79 20 61 67 61 69 6e 2e will try again.
5fb0: 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 ")..... (t
5fc0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 20 hread-sleep! 1)
5fd0: 3b 3b 20 6a 75 73 74 20 62 65 63 61 75 73 65 0a ;; just because.
5fe0: 09 09 09 09 20 20 20 20 20 20 20 23 74 29 29 29 .... #t)))
5ff0: 29 29 0a 09 09 09 20 20 20 20 28 65 6c 73 65 20 )).... (else
6000: 3b 3b 20 73 68 6f 75 6c 64 20 6e 65 76 65 72 20 ;; should never
6010: 67 65 74 20 68 65 72 65 0a 09 09 09 20 20 20 20 get here....
6020: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
6030: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6040: 74 2a 20 22 42 41 44 20 53 45 52 56 45 52 20 52 t* "BAD SERVER R
6050: 45 43 4f 52 44 3a 20 22 6c 65 61 64 73 72 76 29 ECORD: "leadsrv)
6060: 0a 09 09 09 20 20 20 20 20 28 61 73 73 65 72 74 .... (assert
6070: 20 23 66 20 22 42 61 64 20 73 65 72 76 65 72 20 #f "Bad server
6080: 72 65 63 6f 72 64 20 22 6c 65 61 64 73 72 76 29 record "leadsrv)
6090: 29 29 29 29 29 29 29 0a 09 28 69 66 20 6f 6b 0a )))))))..(if ok.
60a0: 09 20 20 20 20 28 74 74 2d 6c 61 73 74 2d 61 63 . (tt-last-ac
60b0: 63 65 73 73 2d 73 65 74 21 20 74 74 64 61 74 20 cess-set! ttdat
60c0: 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a *db-last-access*
60d0: 29 20 3b 3b 20 62 69 74 20 73 69 6c 6c 79 2c 20 ) ;; bit silly,
60e0: 6a 75 73 74 20 75 73 65 20 64 62 2d 6c 61 73 74 just use db-last
60f0: 2d 61 63 63 65 73 73 0a 09 20 20 20 20 28 62 65 -access.. (be
6100: 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 gin.. (debu
6110: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
6120: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 78 lt-log-port* "Ex
6130: 69 74 69 6e 67 20 69 6d 6d 65 64 69 61 74 65 6c iting immediatel
6140: 79 22 29 0a 09 20 20 20 20 20 20 28 63 6c 65 61 y").. (clea
6150: 6e 75 70 29 0a 09 20 20 20 20 20 20 28 65 78 69 nup).. (exi
6160: 74 29 29 29 0a 0a 09 28 6c 65 74 2a 20 28 28 6c t)))...(let* ((l
6170: 61 73 74 2d 75 70 64 61 74 65 20 28 64 62 72 3a ast-update (dbr:
6180: 64 62 73 74 72 75 63 74 2d 6c 61 73 74 2d 75 70 dbstruct-last-up
6190: 64 61 74 65 20 64 62 73 74 72 75 63 74 29 29 0a date dbstruct)).
61a0: 09 20 20 20 20 20 20 20 28 63 75 72 72 2d 73 65 . (curr-se
61b0: 63 73 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 cs (current-se
61c0: 63 6f 6e 64 73 29 29 29 0a 09 20 20 28 69 66 20 conds))).. (if
61d0: 28 61 6e 64 20 28 65 71 3f 20 28 74 74 2d 73 74 (and (eq? (tt-st
61e0: 61 74 65 20 74 74 64 61 74 29 20 27 72 75 6e 6e ate ttdat) 'runn
61f0: 69 6e 67 29 0a 09 09 20 20 20 28 3e 20 28 2d 20 ing)... (> (-
6200: 63 75 72 72 2d 73 65 63 73 20 6c 61 73 74 2d 75 curr-secs last-u
6210: 70 64 61 74 65 29 20 33 29 29 20 3b 3b 20 65 76 pdate) 3)) ;; ev
6220: 65 72 79 20 33 2d 34 20 73 65 63 6f 6e 64 73 20 ery 3-4 seconds
6230: 75 70 64 61 74 65 20 74 68 65 20 64 62 3f 0a 09 update the db?..
6240: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
6250: 73 65 74 21 20 28 66 69 6c 65 2d 6d 6f 64 69 66 set! (file-modif
6260: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 28 74 74 ication-time (tt
6270: 2d 73 65 72 76 69 6e 66 2d 66 69 6c 65 20 74 74 -servinf-file tt
6280: 64 61 74 29 29 20 28 63 75 72 72 65 6e 74 2d 73 dat)) (current-s
6290: 65 63 6f 6e 64 73 29 29 0a 09 09 28 28 64 62 72 econds))...((dbr
62a0: 3a 64 62 73 74 72 75 63 74 2d 73 79 6e 63 2d 70 :dbstruct-sync-p
62b0: 72 6f 63 20 64 62 73 74 72 75 63 74 29 20 6c 61 roc dbstruct) la
62c0: 73 74 2d 75 70 64 61 74 65 29 0a 09 09 28 64 62 st-update)...(db
62d0: 72 3a 64 62 73 74 72 75 63 74 2d 6c 61 73 74 2d r:dbstruct-last-
62e0: 75 70 64 61 74 65 2d 73 65 74 21 20 64 62 73 74 update-set! dbst
62f0: 72 75 63 74 20 63 75 72 72 2d 73 65 63 73 29 29 ruct curr-secs))
6300: 29 29 0a 09 20 20 0a 09 28 69 66 20 28 3c 20 28 )).. ..(if (< (
6310: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
6320: 64 73 29 20 28 74 74 2d 6c 61 73 74 2d 61 63 63 ds) (tt-last-acc
6330: 65 73 73 20 74 74 64 61 74 29 29 20 28 74 74 2d ess ttdat)) (tt-
6340: 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 2d 70 server-timeout-p
6350: 61 72 61 6d 29 29 0a 09 20 20 20 20 28 62 65 67 aram)).. (beg
6360: 69 6e 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 in.. (threa
6370: 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 20 20 20 d-sleep! 5)..
6380: 20 20 20 28 6c 6f 6f 70 29 29 29 29 29 0a 20 20 (loop))))).
6390: 20 20 28 63 6c 65 61 6e 75 70 29 0a 20 20 20 20 (cleanup).
63a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
63b0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
63c0: 2a 20 22 49 4e 46 4f 3a 20 53 65 72 76 65 72 20 * "INFO: Server
63d0: 74 69 6d 65 64 20 6f 75 74 2c 20 65 78 69 74 69 timed out, exiti
63e0: 6e 67 20 66 72 6f 6d 20 74 74 3a 6b 65 65 70 2d ng from tt:keep-
63f0: 72 75 6e 6e 69 6e 67 2e 22 29 29 29 0a 0a 20 20 running.")))..
6400: 0a 3b 3b 20 3b 3b 20 67 69 76 65 6e 20 61 6e 20 .;; ;; given an
6410: 61 6c 72 65 61 64 79 20 73 65 74 20 75 70 20 75 already set up u
6420: 63 6f 6e 6e 20 73 74 61 72 74 20 74 68 65 20 63 conn start the c
6430: 6d 64 2d 6c 6f 6f 70 0a 3b 3b 20 3b 3b 0a 3b 3b md-loop.;; ;;.;;
6440: 20 28 64 65 66 69 6e 65 20 28 74 74 3a 63 6d 64 (define (tt:cmd
6450: 2d 6c 6f 6f 70 20 74 74 64 61 74 29 0a 3b 3b 20 -loop ttdat).;;
6460: 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 2d 6c (let* ((serv-l
6470: 69 73 74 65 6e 65 72 20 28 2d 73 6f 63 6b 65 74 istener (-socket
6480: 20 75 63 6f 6e 6e 29 29 0a 3b 3b 20 09 20 28 6c uconn)).;; . (l
6490: 69 73 74 65 6e 65 72 20 20 20 20 20 20 28 6c 61 istener (la
64a0: 6d 62 64 61 20 28 29 0a 3b 3b 20 09 09 09 20 20 mbda ().;; ...
64b0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 74 61 74 (let loop ((stat
64c0: 65 20 27 73 74 61 72 74 29 29 0a 3b 3b 20 09 09 e 'start)).;; ..
64d0: 09 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 . (let-values
64e0: 20 28 28 28 69 6e 70 20 6f 75 70 29 28 74 63 70 (((inp oup)(tcp
64f0: 2d 61 63 63 65 70 74 20 73 65 72 76 2d 6c 69 73 -accept serv-lis
6500: 74 65 6e 65 72 29 29 29 0a 3b 3b 20 09 09 09 20 tener))).;; ...
6510: 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c ;; (mutex-l
6520: 6f 63 6b 21 20 2a 73 65 6e 64 2d 6d 75 74 65 78 ock! *send-mutex
6530: 2a 29 20 3b 3b 20 44 4f 45 53 4e 27 54 20 53 45 *) ;; DOESN'T SE
6540: 45 4d 20 54 4f 20 48 45 4c 50 0a 3b 3b 20 09 09 EM TO HELP.;; ..
6550: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 . (let* ((r
6560: 64 61 74 20 20 28 64 65 73 65 72 69 61 6c 69 7a dat (deserializ
6570: 65 20 69 6e 70 29 29 20 3b 3b 20 27 28 6d 79 2d e inp)) ;; '(my-
6580: 68 6f 73 74 2d 70 6f 72 74 20 71 72 79 6b 65 79 host-port qrykey
6590: 20 63 6d 64 20 70 61 72 61 6d 73 29 0a 3b 3b 20 cmd params).;;
65a0: 09 09 09 09 20 20 20 20 20 28 72 65 73 70 20 20 .... (resp
65b0: 28 75 6c 65 78 2d 68 61 6e 64 6c 65 72 20 75 63 (ulex-handler uc
65c0: 6f 6e 6e 20 72 64 61 74 29 29 29 0a 3b 3b 20 09 onn rdat))).;; .
65d0: 09 09 09 28 73 65 72 69 61 6c 69 7a 65 20 72 65 ...(serialize re
65e0: 73 70 20 6f 75 70 29 0a 3b 3b 20 09 09 09 09 28 sp oup).;; ....(
65f0: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
6600: 20 69 6e 70 29 0a 3b 3b 20 09 09 09 09 28 63 6c inp).;; ....(cl
6610: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
6620: 6f 75 70 29 0a 3b 3b 20 09 09 09 09 3b 3b 20 28 oup).;; ....;; (
6630: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 73 mutex-unlock! *s
6640: 65 6e 64 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 44 end-mutex*) ;; D
6650: 4f 45 53 4e 27 54 20 53 45 45 4d 20 54 4f 20 48 OESN'T SEEM TO H
6660: 45 4c 50 0a 3b 3b 20 09 09 09 09 29 0a 3b 3b 20 ELP.;; ....).;;
6670: 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 73 ... (loop s
6680: 74 61 74 65 29 29 29 29 29 29 0a 3b 3b 20 20 20 tate)))))).;;
6690: 20 20 3b 3b 20 73 74 61 72 74 20 4e 20 6f 66 20 ;; start N of
66a0: 74 68 65 6d 0a 3b 3b 20 20 20 20 20 28 6c 65 74 them.;; (let
66b0: 20 6c 6f 6f 70 20 28 28 74 68 6e 75 6d 20 20 20 loop ((thnum
66c0: 30 29 0a 3b 3b 20 09 20 20 20 20 20 20 20 28 74 0).;; . (t
66d0: 68 72 65 61 64 73 20 27 28 29 29 29 0a 3b 3b 20 hreads '())).;;
66e0: 20 20 20 20 20 20 28 69 66 20 28 3c 20 74 68 6e (if (< thn
66f0: 75 6d 20 31 30 30 29 0a 3b 3b 20 09 20 20 28 6c um 100).;; . (l
6700: 65 74 2a 20 28 28 74 68 20 28 6d 61 6b 65 2d 74 et* ((th (make-t
6710: 68 72 65 61 64 20 6c 69 73 74 65 6e 65 72 20 28 hread listener (
6720: 63 6f 6e 63 20 22 6c 69 73 74 65 6e 65 72 22 20 conc "listener"
6730: 74 68 6e 75 6d 29 29 29 29 0a 3b 3b 20 09 20 20 thnum)))).;; .
6740: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
6750: 20 74 68 29 0a 3b 3b 20 09 20 20 20 20 28 6c 6f th).;; . (lo
6760: 6f 70 20 28 2b 20 74 68 6e 75 6d 20 31 29 0a 3b op (+ thnum 1).;
6770: 3b 20 09 09 20 20 28 63 6f 6e 73 20 74 68 20 74 ; .. (cons th t
6780: 68 72 65 61 64 73 29 29 29 0a 3b 3b 20 09 20 20 hreads))).;; .
6790: 28 6d 61 70 20 74 68 72 65 61 64 2d 6a 6f 69 6e (map thread-join
67a0: 21 20 74 68 72 65 61 64 73 29 29 29 29 29 0a 3b ! threads))))).;
67b0: 3b 20 0a 3b 3b 20 0a 3b 3b 20 0a 3b 3b 20 28 64 ; .;; .;; .;; (d
67c0: 65 66 69 6e 65 20 28 77 61 69 74 2d 61 6e 64 2d efine (wait-and-
67d0: 63 6c 6f 73 65 20 75 63 6f 6e 6e 29 0a 3b 3b 20 close uconn).;;
67e0: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join!
67f0: 28 75 64 61 74 2d 63 6d 64 2d 74 68 72 65 61 64 (udat-cmd-thread
6800: 20 75 63 6f 6e 6e 29 29 0a 3b 3b 20 20 20 28 74 uconn)).;; (t
6810: 63 70 2d 63 6c 6f 73 65 20 28 75 64 61 74 2d 73 cp-close (udat-s
6820: 6f 63 6b 65 74 20 75 63 6f 6e 6e 29 29 29 0a 3b ocket uconn))).;
6830: 3b 20 0a 3b 3b 20 0a 0a 28 64 65 66 69 6e 65 20 ; .;; ..(define
6840: 28 74 74 3a 73 68 75 74 64 6f 77 6e 2d 73 65 72 (tt:shutdown-ser
6850: 76 65 72 20 74 74 64 61 74 29 0a 20 20 28 6c 65 ver ttdat). (le
6860: 74 2a 20 28 28 63 6c 65 61 6e 70 72 6f 63 20 28 t* ((cleanproc (
6870: 74 74 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 tt-cleanup-proc
6880: 74 74 64 61 74 29 29 0a 09 20 28 70 6f 72 74 20 ttdat)).. (port
6890: 20 20 20 20 20 28 74 74 2d 70 6f 72 74 20 20 20 (tt-port
68a0: 20 20 20 20 20 20 74 74 64 61 74 29 29 29 0a 20 ttdat))).
68b0: 20 20 20 28 74 74 2d 73 74 61 74 65 2d 73 65 74 (tt-state-set
68c0: 21 20 74 74 64 61 74 20 27 73 68 75 74 64 6f 77 ! ttdat 'shutdow
68d0: 6e 29 0a 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 n). (portlogg
68e0: 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 er:open-run-clos
68f0: 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 e portlogger:set
6900: 2d 70 6f 72 74 20 70 6f 72 74 20 22 72 65 6c 65 -port port "rele
6910: 61 73 65 64 22 29 0a 20 20 20 20 28 69 66 20 63 ased"). (if c
6920: 6c 65 61 6e 70 72 6f 63 20 28 63 6c 65 61 6e 70 leanproc (cleanp
6930: 72 6f 63 29 29 0a 20 20 20 20 28 74 63 70 2d 63 roc)). (tcp-c
6940: 6c 6f 73 65 20 28 74 74 2d 73 6f 63 6b 65 74 20 lose (tt-socket
6950: 74 74 64 61 74 29 29 20 3b 3b 20 63 6c 6f 73 65 ttdat)) ;; close
6960: 20 75 70 20 70 6f 72 74 73 20 68 65 72 65 0a 20 up ports here.
6970: 20 20 20 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e ))..;; (defin
6980: 65 20 28 77 61 69 74 2d 61 6e 64 2d 63 6c 6f 73 e (wait-and-clos
6990: 65 20 75 63 6f 6e 6e 29 0a 3b 3b 20 20 20 28 74 e uconn).;; (t
69a0: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 28 74 74 2d hread-join! (tt-
69b0: 63 6d 64 2d 74 68 72 65 61 64 20 75 63 6f 6e 6e cmd-thread uconn
69c0: 29 29 0a 3b 3b 20 20 20 28 74 63 70 2d 63 6c 6f )).;; (tcp-clo
69d0: 73 65 20 28 74 74 2d 73 6f 63 6b 65 74 20 75 63 se (tt-socket uc
69e0: 6f 6e 6e 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 onn)))..;; retur
69f0: 6e 20 73 65 72 76 69 64 0a 3b 3b 20 73 69 64 65 n servid.;; side
6a00: 2d 65 66 66 65 63 74 73 3a 0a 3b 3b 20 20 20 74 -effects:.;; t
6a10: 74 64 61 74 2d 63 6c 65 61 6e 75 70 2d 70 72 6f tdat-cleanup-pro
6a20: 63 20 69 73 20 70 6f 70 75 6c 61 74 65 64 20 77 c is populated w
6a30: 69 74 68 20 66 75 6e 63 74 69 6f 6e 20 74 6f 20 ith function to
6a40: 72 65 6d 6f 76 65 20 74 68 65 20 73 65 72 76 65 remove the serve
6a50: 72 69 6e 66 6f 20 66 69 6c 65 0a 28 64 65 66 69 rinfo file.(defi
6a60: 6e 65 20 28 74 74 3a 63 72 65 61 74 65 2d 73 65 ne (tt:create-se
6a70: 72 76 65 72 2d 72 65 67 69 73 74 72 61 74 69 6f rver-registratio
6a80: 6e 2d 66 69 6c 65 20 74 74 64 61 74 20 64 62 66 n-file ttdat dbf
6a90: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 name). (let* ((
6aa0: 61 72 65 61 70 61 74 68 20 28 74 74 2d 61 72 65 areapath (tt-are
6ab0: 61 70 61 74 68 20 74 74 64 61 74 29 29 0a 09 20 apath ttdat))..
6ac0: 28 73 65 72 76 64 69 72 20 20 28 74 74 3a 67 65 (servdir (tt:ge
6ad0: 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 t-servinfo-dir a
6ae0: 72 65 61 70 61 74 68 29 29 0a 09 20 28 68 6f 73 reapath)).. (hos
6af0: 74 20 20 20 20 20 28 74 74 2d 68 6f 73 74 20 74 t (tt-host t
6b00: 74 64 61 74 29 29 0a 09 20 28 70 6f 72 74 20 20 tdat)).. (port
6b10: 20 20 20 28 74 74 2d 70 6f 72 74 20 74 74 64 61 (tt-port ttda
6b20: 74 29 29 0a 09 20 28 73 65 72 76 69 6e 66 20 28 t)).. (servinf (
6b30: 63 6f 6e 63 20 73 65 72 76 64 69 72 22 2f 22 68 conc servdir"/"h
6b40: 6f 73 74 22 3a 22 70 6f 72 74 22 2d 22 28 63 75 ost":"port"-"(cu
6b50: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
6b60: 29 22 3a 22 64 62 66 6e 61 6d 65 29 29 0a 09 20 )":"dbfname))..
6b70: 28 73 65 72 76 2d 69 64 20 28 74 74 3a 6d 6b 2d (serv-id (tt:mk-
6b80: 73 69 67 6e 61 74 75 72 65 20 61 72 65 61 70 61 signature areapa
6b90: 74 68 29 29 0a 09 20 28 63 6c 65 61 6e 2d 70 72 th)).. (clean-pr
6ba0: 6f 63 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 oc (lambda ()...
6bb0: 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 (delete-f
6bc0: 69 6c 65 2a 20 73 65 72 76 69 6e 66 29 0a 09 09 ile* servinf)...
6bd0: 20 20 20 20 20 20 20 29 29 29 0a 20 20 20 20 28 ))). (
6be0: 61 73 73 65 72 74 20 28 61 6e 64 20 68 6f 73 74 assert (and host
6bf0: 20 70 6f 72 74 29 20 22 46 41 54 41 4c 3a 20 74 port) "FATAL: t
6c00: 74 3a 63 72 65 61 74 65 2d 73 65 72 76 65 72 2d t:create-server-
6c10: 72 65 67 69 73 74 72 61 74 69 6f 6e 2d 66 69 6c registration-fil
6c20: 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f e called with no
6c30: 20 63 6f 6e 6e 2c 20 64 62 66 6e 61 6d 65 3d 22 conn, dbfname="
6c40: 64 62 66 6e 61 6d 65 29 0a 20 20 20 20 28 74 74 dbfname). (tt
6c50: 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 2d 73 65 -cleanup-proc-se
6c60: 74 21 20 74 74 64 61 74 20 63 6c 65 61 6e 2d 70 t! ttdat clean-p
6c70: 72 6f 63 29 0a 20 20 20 20 28 74 74 2d 73 65 72 roc). (tt-ser
6c80: 76 69 6e 66 2d 66 69 6c 65 2d 73 65 74 21 20 74 vinf-file-set! t
6c90: 74 64 61 74 20 73 65 72 76 69 6e 66 29 0a 20 20 tdat servinf).
6ca0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
6cb0: 6f 2d 66 69 6c 65 20 73 65 72 76 69 6e 66 0a 20 o-file servinf.
6cc0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
6cd0: 09 28 70 72 69 6e 74 20 22 53 45 52 56 45 52 20 .(print "SERVER
6ce0: 53 54 41 52 54 45 44 3a 20 22 68 6f 73 74 22 3a STARTED: "host":
6cf0: 22 70 6f 72 74 22 20 41 54 20 22 28 63 75 72 72 "port" AT "(curr
6d00: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 22 20 73 65 ent-seconds)" se
6d10: 72 76 65 72 2d 69 64 3a 20 22 73 65 72 76 2d 69 rver-id: "serv-i
6d20: 64 22 20 70 69 64 3a 20 22 28 63 75 72 72 65 6e d" pid: "(curren
6d30: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 64 t-process-id)" d
6d40: 62 66 6e 61 6d 65 3a 20 22 64 62 66 6e 61 6d 65 bfname: "dbfname
6d50: 29 29 29 0a 20 20 20 20 20 20 73 65 72 76 2d 69 ))). serv-i
6d60: 64 29 29 0a 0a 3b 3b 20 66 69 6e 64 20 76 61 6c d))..;; find val
6d70: 69 64 20 73 65 72 76 65 72 0a 3b 3b 20 67 65 74 id server.;; get
6d80: 20 73 65 72 76 65 72 73 20 6c 69 73 74 65 64 2c servers listed,
6d90: 20 6c 61 73 74 20 70 61 72 74 20 6f 66 20 6e 61 last part of na
6da0: 6d 65 20 6d 75 73 74 20 6d 61 74 63 68 20 3a 3c me must match :<
6db0: 64 62 66 6e 61 6d 65 3e 0a 3b 3b 20 69 66 20 6d dbfname>.;; if m
6dc0: 6f 72 65 20 74 68 61 6e 20 6f 6e 65 2c 20 77 61 ore than one, wa
6dd0: 69 74 20 6f 6e 65 20 73 65 63 6f 6e 64 20 61 6e it one second an
6de0: 64 20 6c 6f 6f 6b 20 61 67 61 69 6e 0a 3b 3b 20 d look again.;;
6df0: 66 75 74 75 72 65 3a 20 70 69 6e 67 20 6f 6c 64 future: ping old
6e00: 65 73 74 2c 20 69 66 20 61 6c 69 76 65 20 72 65 est, if alive re
6e10: 6d 6f 76 65 20 6f 74 68 65 72 20 3a 3c 64 62 66 move other :<dbf
6e20: 6e 61 6d 65 3e 20 66 69 6c 65 73 0a 3b 3b 0a 28 name> files.;;.(
6e30: 64 65 66 69 6e 65 20 28 74 74 3a 66 69 6e 64 2d define (tt:find-
6e40: 73 65 72 76 65 72 20 61 72 65 61 70 61 74 68 20 server areapath
6e50: 64 62 66 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a dbfname). (let*
6e60: 20 28 28 73 65 72 76 64 69 72 20 20 28 74 74 3a ((servdir (tt:
6e70: 67 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 get-servinfo-dir
6e80: 20 61 72 65 61 70 61 74 68 29 29 0a 09 20 28 73 areapath)).. (s
6e90: 66 69 6c 65 73 20 20 20 28 67 6c 6f 62 20 28 63 files (glob (c
6ea0: 6f 6e 63 20 73 65 72 76 64 69 72 22 2f 2a 3a 22 onc servdir"/*:"
6eb0: 64 62 66 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 dbfname))).
6ec0: 20 20 20 20 28 67 6f 6f 64 2d 66 69 6c 65 73 20 (good-files
6ed0: 27 28 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 '())). (
6ee0: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 20 for-each .
6ef0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 66 (lambda (sf
6f00: 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ile).
6f10: 20 20 28 6c 65 74 2a 20 28 28 73 69 6e 66 6f 20 (let* ((sinfo
6f20: 28 74 74 3a 73 65 72 76 65 72 2d 67 65 74 2d 69 (tt:server-get-i
6f30: 6e 66 6f 20 73 66 69 6c 65 29 29 0a 20 20 20 20 nfo sfile)).
6f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 6f (ho
6f50: 73 74 20 28 6c 69 73 74 2d 72 65 66 20 73 69 6e st (list-ref sin
6f60: 66 6f 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 fo 0)).
6f70: 20 20 20 20 20 20 20 20 28 70 6f 72 74 20 28 6c (port (l
6f80: 69 73 74 2d 72 65 66 20 73 69 6e 66 6f 20 31 29 ist-ref sinfo 1)
6f90: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6fa0: 20 20 20 28 73 65 72 76 65 72 2d 69 64 20 28 6c (server-id (l
6fb0: 69 73 74 2d 72 65 66 20 73 69 6e 66 6f 20 33 29 ist-ref sinfo 3)
6fc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6fd0: 20 20 20 28 70 69 64 20 28 6c 69 73 74 2d 72 65 (pid (list-re
6fe0: 66 20 73 69 6e 66 6f 20 34 29 29 0a 20 20 20 20 f sinfo 4)).
6ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
7000: 61 74 75 73 20 28 73 79 73 74 65 6d 20 28 63 6f atus (system (co
7010: 6e 63 20 22 73 73 68 20 22 20 68 6f 73 74 20 22 nc "ssh " host "
7020: 20 70 73 20 22 20 70 69 64 20 22 20 3e 20 2f 64 ps " pid " > /d
7030: 65 76 2f 6e 75 6c 6c 22 29 29 29 0a 20 20 20 20 ev/null"))).
7040: 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 ).
7050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7060: 69 66 20 28 3d 20 73 74 61 74 75 73 20 30 29 0a if (= status 0).
7070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7080: 20 20 28 73 65 74 21 20 67 6f 6f 64 2d 66 69 6c (set! good-fil
7090: 65 73 20 28 63 6f 6e 73 20 73 66 69 6c 65 20 67 es (cons sfile g
70a0: 6f 6f 64 2d 66 69 6c 65 73 29 29 0a 20 20 20 20 ood-files)).
70b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
70c0: 65 6c 65 74 65 2d 66 69 6c 65 2a 20 73 66 69 6c elete-file* sfil
70d0: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
70e0: 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 ).
70f0: 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 29 ). )
7100: 0a 20 20 20 20 20 20 20 20 20 20 20 73 66 69 6c . sfil
7110: 65 73 0a 20 20 20 20 20 20 20 20 20 29 0a 20 20 es. ).
7120: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
7130: 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 2 *default-l
7140: 6f 67 2d 70 6f 72 74 2a 20 22 74 74 3a 66 69 6e og-port* "tt:fin
7150: 64 2d 73 65 72 76 65 72 3a 20 67 6f 6f 64 2d 66 d-server: good-f
7160: 69 6c 65 73 3a 20 22 20 67 6f 6f 64 2d 66 69 6c iles: " good-fil
7170: 65 73 20 22 20 73 66 69 6c 65 73 3a 20 22 20 73 es " sfiles: " s
7180: 66 69 6c 65 73 29 0a 20 20 20 20 67 6f 6f 64 2d files). good-
7190: 66 69 6c 65 73 29 29 0a 0a 3b 3b 20 67 69 76 65 files))..;; give
71a0: 6e 20 61 20 70 61 74 68 20 74 6f 20 61 20 73 65 n a path to a se
71b0: 72 76 65 72 20 69 6e 66 6f 20 66 69 6c 65 20 72 rver info file r
71c0: 65 74 75 72 6e 3a 20 68 6f 73 74 20 70 6f 72 74 eturn: host port
71d0: 20 73 74 61 72 74 73 65 63 6f 6e 64 73 20 73 65 startseconds se
71e0: 72 76 65 72 2d 69 64 20 70 69 64 20 64 62 66 6e rver-id pid dbfn
71f0: 61 6d 65 20 6c 6f 67 66 0a 3b 3b 20 65 78 61 6d ame logf.;; exam
7200: 70 6c 65 20 6f 66 20 77 68 61 74 20 69 74 27 73 ple of what it's
7210: 20 6c 6f 6f 6b 69 6e 67 20 66 6f 72 20 69 6e 20 looking for in
7220: 74 68 65 20 6c 6f 67 20 66 69 6c 65 3a 0a 3b 3b the log file:.;;
7230: 20 20 20 20 20 53 45 52 56 45 52 20 53 54 41 52 SERVER STAR
7240: 54 45 44 3a 20 31 30 2e 33 38 2e 31 37 35 2e 36 TED: 10.38.175.6
7250: 37 3a 35 30 32 31 36 20 41 54 20 31 36 31 36 35 7:50216 AT 16165
7260: 30 32 33 35 30 2e 30 20 73 65 72 76 65 72 2d 69 02350.0 server-i
7270: 64 3a 20 34 39 30 37 65 39 30 66 63 35 35 63 37 d: 4907e90fc55c7
7280: 61 30 39 36 39 34 65 33 66 36 35 38 63 36 33 39 a09694e3f658c639
7290: 63 66 34 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 cf4 .;;.(define
72a0: 28 74 74 3a 73 65 72 76 65 72 2d 67 65 74 2d 69 (tt:server-get-i
72b0: 6e 66 6f 20 6c 6f 67 66 29 0a 20 20 28 6c 65 74 nfo logf). (let
72c0: 20 28 28 73 65 72 76 65 72 2d 72 78 20 20 20 20 ((server-rx
72d0: 28 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 52 (regexp "^SERVER
72e0: 20 53 54 41 52 54 45 44 3a 20 28 5c 5c 53 2b 29 STARTED: (\\S+)
72f0: 3a 28 5c 5c 64 2b 29 20 41 54 20 28 5b 5c 5c 64 :(\\d+) AT ([\\d
7300: 5c 5c 2e 5d 2b 29 20 73 65 72 76 65 72 2d 69 64 \\.]+) server-id
7310: 3a 20 28 5c 5c 53 2b 29 20 70 69 64 3a 20 28 5c : (\\S+) pid: (\
7320: 5c 64 2b 29 20 64 62 66 6e 61 6d 65 3a 20 28 5c \d+) dbfname: (\
7330: 5c 53 2b 29 22 29 29 20 3b 3b 20 53 45 52 56 45 \S+)")) ;; SERVE
7340: 52 20 53 54 41 52 54 45 44 3a 20 68 6f 73 74 3a R STARTED: host:
7350: 70 6f 72 74 20 41 54 20 74 69 6d 65 73 65 63 73 port AT timesecs
7360: 20 73 65 72 76 65 72 20 69 64 0a 20 20 20 20 20 server id.
7370: 20 20 20 28 64 62 70 72 65 70 2d 72 78 20 20 20 (dbprep-rx
7380: 20 28 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 (regexp "^SERVE
7390: 52 3a 20 64 62 70 72 65 70 22 29 29 0a 20 20 20 R: dbprep")).
73a0: 20 20 20 20 20 28 64 62 70 72 65 70 2d 66 6f 75 (dbprep-fou
73b0: 6e 64 20 30 29 0a 09 28 62 61 64 2d 64 61 74 20 nd 0)..(bad-dat
73c0: 20 20 20 20 20 28 6c 69 73 74 20 23 66 20 23 66 (list #f #f
73d0: 20 23 66 20 23 66 20 23 66 20 23 66 20 6c 6f 67 #f #f #f #f log
73e0: 66 29 29 29 0a 20 20 20 20 20 28 6c 65 74 20 28 f))). (let (
73f0: 28 66 64 61 74 20 20 20 20 20 28 68 61 6e 64 6c (fdat (handl
7400: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
7410: 20 65 78 6e 0a 09 09 20 20 20 20 20 20 20 28 62 exn... (b
7420: 65 67 69 6e 0a 09 09 09 20 3b 3b 20 57 41 52 4e egin.... ;; WARN
7430: 49 4e 47 3a 20 74 68 69 73 20 69 73 20 70 6f 74 ING: this is pot
7440: 65 6e 74 69 61 6c 6c 79 20 64 61 6e 67 65 72 6f entially dangero
7450: 75 73 20 74 6f 20 62 6c 61 6e 6b 65 74 20 69 67 us to blanket ig
7460: 6e 6f 72 65 20 74 68 65 20 65 72 72 6f 72 73 0a nore the errors.
7470: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
7480: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
7490: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 61 62 -log-port* "Unab
74a0: 6c 65 20 74 6f 20 67 65 74 20 73 65 72 76 65 72 le to get server
74b0: 20 69 6e 66 6f 20 66 72 6f 6d 20 22 6c 6f 67 66 info from "logf
74c0: 22 2c 20 65 78 6e 3d 22 28 63 6f 6e 64 69 74 69 ", exn="(conditi
74d0: 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 on->list exn))..
74e0: 09 09 20 27 28 29 29 20 3b 3b 20 6e 6f 20 69 64 .. '()) ;; no id
74f0: 65 61 20 77 68 61 74 20 77 65 6e 74 20 77 72 6f ea what went wro
7500: 6e 67 2c 20 63 61 6c 6c 20 69 74 20 61 20 62 61 ng, call it a ba
7510: 64 20 73 65 72 76 65 72 2c 20 72 65 74 75 72 6e d server, return
7520: 20 65 6d 70 74 79 20 6c 69 73 74 0a 09 09 20 20 empty list...
7530: 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
7540: 2d 66 72 6f 6d 2d 66 69 6c 65 20 6c 6f 67 66 20 -from-file logf
7550: 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 0a 20 read-lines)))).
7560: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
7570: 20 66 64 61 74 29 20 3b 3b 20 62 61 64 20 64 61 fdat) ;; bad da
7580: 74 61 2c 20 72 65 74 75 72 6e 20 62 61 64 2d 64 ta, return bad-d
7590: 61 74 0a 09 20 20 20 62 61 64 2d 64 61 74 0a 09 at.. bad-dat..
75a0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 (let loop ((i
75b0: 6e 6c 20 20 28 63 61 72 20 66 64 61 74 29 29 0a nl (car fdat)).
75c0: 09 09 20 20 20 20 20 20 28 74 61 69 6c 20 28 63 .. (tail (c
75d0: 64 72 20 66 64 61 74 29 29 0a 09 09 20 20 20 20 dr fdat))...
75e0: 20 20 28 6c 6e 75 6d 20 30 29 29 0a 09 20 20 20 (lnum 0))..
75f0: 20 20 28 6c 65 74 20 28 28 6d 6c 73 74 20 28 73 (let ((mlst (s
7600: 74 72 69 6e 67 2d 6d 61 74 63 68 20 73 65 72 76 tring-match serv
7610: 65 72 2d 72 78 20 69 6e 6c 29 29 0a 09 09 20 20 er-rx inl))...
7620: 20 28 64 62 70 72 65 70 20 28 73 74 72 69 6e 67 (dbprep (string
7630: 2d 6d 61 74 63 68 20 64 62 70 72 65 70 2d 72 78 -match dbprep-rx
7640: 20 69 6e 6c 29 29 29 0a 09 20 20 20 20 20 20 20 inl)))..
7650: 28 69 66 20 64 62 70 72 65 70 20 28 73 65 74 21 (if dbprep (set!
7660: 20 64 62 70 72 65 70 2d 66 6f 75 6e 64 20 31 29 dbprep-found 1)
7670: 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 6e ).. (if (n
7680: 6f 74 20 6d 6c 73 74 29 0a 09 09 20 20 20 28 69 ot mlst)... (i
7690: 66 20 28 3e 20 6c 6e 75 6d 20 35 30 30 29 20 3b f (> lnum 500) ;
76a0: 3b 20 67 69 76 65 20 75 70 20 69 66 20 6d 6f 72 ; give up if mor
76b0: 65 20 74 68 61 6e 20 35 30 30 20 6c 69 6e 65 73 e than 500 lines
76c0: 20 6f 66 20 73 65 72 76 65 72 20 6c 6f 67 20 72 of server log r
76d0: 65 61 64 0a 09 09 20 20 20 20 20 20 20 62 61 64 ead... bad
76e0: 2d 64 61 74 0a 09 09 20 20 20 20 20 20 20 28 69 -dat... (i
76f0: 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 f (null? tail)..
7700: 09 09 20 20 20 62 61 64 2d 64 61 74 0a 09 09 09 .. bad-dat....
7710: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
7720: 69 6c 29 28 63 64 72 20 74 61 69 6c 29 28 2b 20 il)(cdr tail)(+
7730: 6c 6e 75 6d 20 31 29 29 29 29 0a 09 09 20 20 20 lnum 1))))...
7740: 28 6d 61 74 63 68 20 6d 6c 73 74 20 3b 3b 20 68 (match mlst ;; h
7750: 61 76 65 20 61 20 6e 6f 74 20 6e 75 6c 6c 20 6c ave a not null l
7760: 69 73 74 0a 09 09 20 20 20 20 20 28 28 5f 20 68 ist... ((_ h
7770: 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 20 73 ost port start s
7780: 65 72 76 65 72 2d 69 64 20 70 69 64 20 64 62 66 erver-id pid dbf
7790: 6e 61 6d 65 29 0a 09 09 20 20 20 20 20 20 28 6c name)... (l
77a0: 69 73 74 20 68 6f 73 74 0a 09 09 09 20 20 20 20 ist host....
77b0: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
77c0: 70 6f 72 74 29 0a 09 09 09 20 20 20 20 28 73 74 port).... (st
77d0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 73 74 61 ring->number sta
77e0: 72 74 29 0a 09 09 09 20 20 20 20 73 65 72 76 65 rt).... serve
77f0: 72 2d 69 64 0a 09 09 09 20 20 20 20 28 73 74 72 r-id.... (str
7800: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 69 64 29 ing->number pid)
7810: 0a 09 09 09 20 20 20 20 64 62 66 6e 61 6d 65 0a .... dbfname.
7820: 09 09 09 20 20 20 20 6c 6f 67 66 29 29 0a 09 09 ... logf))...
7830: 20 20 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 (else...
7840: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
7850: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
7860: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 64 69 64 ort* "ERROR: did
7870: 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 20 53 not recognise S
7880: 45 52 56 45 52 20 6c 69 6e 65 20 69 6e 66 6f 20 ERVER line info
7890: 22 6d 6c 73 74 29 0a 09 09 20 20 20 20 20 20 62 "mlst)... b
78a0: 61 64 2d 64 61 74 29 29 29 29 29 29 29 29 29 0a ad-dat))))))))).
78b0: 0a 3b 3b 20 47 69 76 65 6e 20 61 6e 20 61 72 65 .;; Given an are
78c0: 61 20 70 61 74 68 2c 20 20 73 74 61 72 74 20 61 a path, start a
78d0: 20 73 65 72 76 65 72 20 70 72 6f 63 65 73 73 20 server process
78e0: 20 20 20 23 23 23 20 4e 4f 54 45 20 23 23 23 20 ### NOTE ###
78f0: 3e 20 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 > file 2>&1 .;;
7900: 69 66 20 74 68 65 20 74 61 72 67 65 74 2d 68 6f if the target-ho
7910: 73 74 20 69 73 20 73 65 74 20 0a 3b 3b 20 74 72 st is set .;; tr
7920: 79 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 68 61 y running on tha
7930: 74 20 68 6f 73 74 0a 3b 3b 20 20 20 69 6e 63 69 t host.;; inci
7940: 64 65 6e 74 61 6c 3a 20 72 6f 74 61 74 65 20 6c dental: rotate l
7950: 6f 67 73 20 69 6e 20 6c 6f 67 73 2f 20 64 69 72 ogs in logs/ dir
7960: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 20 28 74 ..;;.(define (t
7970: 74 3a 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 t:server-process
7980: 2d 72 75 6e 20 61 72 65 61 70 61 74 68 20 74 65 -run areapath te
7990: 73 74 73 75 69 74 65 20 6d 74 65 78 65 20 72 75 stsuite mtexe ru
79a0: 6e 2d 69 64 20 23 21 6b 65 79 20 28 70 72 6f 66 n-id #!key (prof
79b0: 69 6c 65 2d 6d 6f 64 65 20 22 22 29 29 20 3b 3b ile-mode "")) ;;
79c0: 20 61 72 65 61 70 61 74 68 20 69 73 20 2a 74 6f areapath is *to
79d0: 70 70 61 74 68 2a 20 66 6f 72 20 61 20 67 69 76 ppath* for a giv
79e0: 65 6e 20 74 65 73 74 73 75 69 74 65 20 61 72 65 en testsuite are
79f0: 61 0a 20 20 28 61 73 73 65 72 74 20 61 72 65 61 a. (assert area
7a00: 70 61 74 68 20 20 22 46 41 54 41 4c 3a 20 74 74 path "FATAL: tt
7a10: 3a 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 2d :server-process-
7a20: 72 75 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 6f run called witho
7a30: 75 74 20 61 72 65 61 70 61 74 68 20 64 65 66 69 ut areapath defi
7a40: 6e 65 64 2e 22 29 0a 20 20 28 61 73 73 65 72 74 ned."). (assert
7a50: 20 74 65 73 74 73 75 69 74 65 20 22 46 41 54 41 testsuite "FATA
7a60: 4c 3a 20 74 74 3a 73 65 72 76 65 72 2d 70 72 6f L: tt:server-pro
7a70: 63 65 73 73 2d 72 75 6e 20 63 61 6c 6c 65 64 20 cess-run called
7a80: 77 69 74 68 6f 75 74 20 74 65 73 74 73 75 69 74 without testsuit
7a90: 65 20 64 65 66 69 6e 65 64 2e 22 29 0a 20 20 28 e defined."). (
7aa0: 61 73 73 65 72 74 20 6d 74 65 78 65 20 20 20 20 assert mtexe
7ab0: 20 22 46 41 54 41 4c 3a 20 74 74 3a 73 65 72 76 "FATAL: tt:serv
7ac0: 65 72 2d 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 er-process-run c
7ad0: 61 6c 6c 65 64 20 77 69 74 68 6f 75 74 20 6d 74 alled without mt
7ae0: 65 78 65 20 64 65 66 69 6e 65 64 2e 22 29 0a 20 exe defined.").
7af0: 20 3b 3b 20 6d 74 65 73 74 20 2d 73 65 72 76 65 ;; mtest -serve
7b00: 72 20 2d 20 2d 6d 20 74 65 73 74 73 75 69 74 65 r - -m testsuite
7b10: 3a 65 78 74 2d 74 65 73 74 73 20 2d 64 62 20 36 :ext-tests -db 6
7b20: 2e 64 62 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 .db. (let* ((db
7b30: 66 6e 61 6d 65 20 20 28 64 62 6d 6f 64 3a 72 75 fname (dbmod:ru
7b40: 6e 2d 69 64 2d 3e 64 62 66 6e 61 6d 65 20 72 75 n-id->dbfname ru
7b50: 6e 2d 69 64 29 29 0a 09 20 28 6c 6f 61 64 20 20 n-id)).. (load
7b60: 20 20 20 28 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a (get-normaliz
7b70: 65 64 2d 63 70 75 2d 6c 6f 61 64 29 29 0a 09 20 ed-cpu-load))..
7b80: 28 74 72 79 69 6e 67 20 20 20 28 6c 65 6e 67 74 (trying (lengt
7b90: 68 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 h (tt:find-serve
7ba0: 72 20 61 72 65 61 70 61 74 68 20 64 62 66 6e 61 r areapath dbfna
7bb0: 6d 65 29 29 29 0a 09 20 28 6e 72 75 6e 20 20 20 me))).. (nrun
7bc0: 20 20 28 6e 75 6d 62 65 72 2d 6f 66 2d 70 72 6f (number-of-pro
7bd0: 63 65 73 73 65 73 2d 72 75 6e 6e 69 6e 67 20 28 cesses-running (
7be0: 63 6f 6e 63 20 22 6d 74 65 73 74 2e 2a 73 65 72 conc "mtest.*ser
7bf0: 76 65 72 2e 2a 22 74 65 73 74 73 75 69 74 65 22 ver.*"testsuite"
7c00: 2e 2a 22 64 62 66 6e 61 6d 65 29 29 29 29 0a 20 .*"dbfname)))).
7c10: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
7c20: 3e 20 6c 6f 61 64 20 32 2e 30 29 0a 20 20 20 20 > load 2.0).
7c30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
7c40: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
7c50: 72 74 2a 20 22 4e 6f 72 6d 61 6c 69 7a 65 64 20 rt* "Normalized
7c60: 6c 6f 61 64 20 22 6c 6f 61 64 22 20 6f 6e 20 22 load "load" on "
7c70: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
7c80: 20 22 20 69 73 20 6f 76 65 72 20 74 68 65 20 6c " is over the l
7c90: 69 6d 69 74 20 6f 66 20 32 2e 30 2e 20 4e 6f 74 imit of 2.0. Not
7ca0: 20 73 74 61 72 74 69 6e 67 20 61 20 73 65 72 76 starting a serv
7cb0: 65 72 2e 22 29 0a 20 20 20 20 20 20 28 74 68 72 er."). (thr
7cc0: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 0a 20 ead-sleep! 1)).
7cd0: 20 20 20 20 28 28 3e 20 6e 72 75 6e 20 31 30 30 ((> nrun 100
7ce0: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
7cf0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
7d00: 6c 6f 67 2d 70 6f 72 74 2a 20 6e 72 75 6e 22 20 log-port* nrun"
7d10: 73 65 72 76 65 72 73 20 72 75 6e 6e 69 6e 67 20 servers running
7d20: 6f 6e 20 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e on " (get-host-n
7d30: 61 6d 65 29 20 22 2c 20 6e 6f 74 20 73 74 61 72 ame) ", not star
7d40: 74 69 6e 67 20 61 6e 6f 74 68 65 72 2e 22 29 0a ting another.").
7d50: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
7d60: 65 65 70 21 20 31 29 29 0a 20 20 20 20 20 28 28 eep! 1)). ((
7d70: 3e 20 74 72 79 69 6e 67 20 34 29 0a 20 20 20 20 > trying 4).
7d80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
7d90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
7da0: 72 74 2a 20 74 72 79 69 6e 67 22 20 73 65 72 76 rt* trying" serv
7db0: 65 72 73 20 72 65 67 69 73 74 65 72 65 64 20 69 ers registered i
7dc0: 6e 20 2e 73 65 72 76 69 6e 66 6f 20 64 69 72 2e n .servinfo dir.
7dd0: 20 6e 6f 74 20 73 74 61 72 74 69 6e 67 20 61 6e not starting an
7de0: 6f 74 68 65 72 2e 22 29 0a 20 20 20 20 20 20 28 other."). (
7df0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
7e00: 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 ). (else.
7e10: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c (if (not (fil
7e20: 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 e-exists? (conc
7e30: 61 72 65 61 70 61 74 68 22 2f 6c 6f 67 73 22 29 areapath"/logs")
7e40: 29 29 0a 09 20 20 20 20 20 20 28 63 72 65 61 74 )).. (creat
7e50: 65 2d 64 69 72 65 63 74 6f 72 79 20 28 63 6f 6e e-directory (con
7e60: 63 20 61 72 65 61 70 61 74 68 22 2f 6c 6f 67 73 c areapath"/logs
7e70: 22 29 20 23 74 29 29 0a 09 20 20 28 6c 65 74 2a ") #t)).. (let*
7e80: 20 28 28 6c 6f 67 66 69 6c 65 20 20 20 28 63 6f ((logfile (co
7e90: 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f 6c 6f nc areapath "/lo
7ea0: 67 73 2f 73 65 72 76 65 72 2d 22 64 62 66 6e 61 gs/server-"dbfna
7eb0: 6d 65 22 2d 22 28 63 75 72 72 65 6e 74 2d 70 72 me"-"(current-pr
7ec0: 6f 63 65 73 73 2d 69 64 29 22 2e 6c 6f 67 22 29 ocess-id)".log")
7ed0: 29 20 3b 3b 20 2d 22 20 63 75 72 72 2d 70 69 64 ) ;; -" curr-pid
7ee0: 20 22 2d 22 20 74 61 72 67 65 74 2d 68 6f 73 74 "-" target-host
7ef0: 20 22 2e 6c 6f 67 22 29 29 0a 09 09 20 28 63 6d ".log"))... (cm
7f00: 64 6c 6e 20 20 20 20 20 28 63 6f 6e 63 0a 09 09 dln (conc...
7f10: 09 20 20 20 20 20 6d 74 65 78 65 0a 09 09 09 20 . mtexe....
7f20: 20 20 20 20 22 20 2d 73 74 61 72 74 64 69 72 20 " -startdir
7f30: 22 61 72 65 61 70 61 74 68 0a 09 09 09 20 20 20 "areapath....
7f40: 20 20 22 20 2d 73 65 72 76 65 72 20 2d 20 22 3b " -server - ";
7f50: 3b 20 28 6f 72 20 74 61 72 67 65 74 2d 68 6f 73 ; (or target-hos
7f60: 74 20 22 2d 22 29 0a 09 09 09 20 20 20 20 20 22 t "-").... "
7f70: 20 2d 6d 20 74 65 73 74 73 75 69 74 65 3a 22 74 -m testsuite:"t
7f80: 65 73 74 73 75 69 74 65 0a 09 09 09 20 20 20 20 estsuite....
7f90: 20 22 20 2d 64 62 20 22 64 62 66 6e 61 6d 65 20 " -db "dbfname
7fa0: 3b 3b 20 28 64 62 6d 6f 64 3a 72 75 6e 2d 69 64 ;; (dbmod:run-id
7fb0: 2d 3e 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 ->dbfname run-id
7fc0: 29 0a 09 09 09 20 20 20 20 20 22 20 22 20 70 72 ).... " " pr
7fd0: 6f 66 69 6c 65 2d 6d 6f 64 65 0a 09 09 09 20 20 ofile-mode....
7fe0: 20 20 20 28 63 6f 6e 63 20 22 20 3e 3e 20 22 20 (conc " >> "
7ff0: 6c 6f 67 66 69 6c 65 20 22 20 32 3e 26 31 20 26 logfile " 2>&1 &
8000: 22 29 29 29 29 0a 09 20 20 20 20 3b 3b 20 77 65 ")))).. ;; we
8010: 20 77 61 6e 74 20 74 68 65 20 72 65 6d 6f 74 65 want the remote
8020: 20 73 65 72 76 65 72 20 74 6f 20 73 74 61 72 74 server to start
8030: 20 69 6e 20 2a 74 6f 70 70 61 74 68 2a 20 73 6f in *toppath* so
8040: 20 70 75 73 68 20 74 68 65 72 65 0a 09 20 20 20 push there..
8050: 20 3b 3b 20 28 70 75 73 68 2d 64 69 72 65 63 74 ;; (push-direct
8060: 6f 72 79 20 61 72 65 61 70 61 74 68 29 20 3b 3b ory areapath) ;;
8070: 20 75 73 65 20 63 64 20 69 6e 20 74 68 65 20 63 use cd in the c
8080: 6f 6d 6d 61 6e 64 20 6c 69 6e 65 20 69 6e 73 74 ommand line inst
8090: 65 61 64 0a 09 20 20 20 20 28 64 65 62 75 67 3a ead.. (debug:
80a0: 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 print 2 *default
80b0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
80c0: 3a 20 54 72 79 69 6e 67 20 74 6f 20 73 74 61 72 : Trying to star
80d0: 74 20 73 65 72 76 65 72 20 69 6e 20 74 63 70 20 t server in tcp
80e0: 6d 6f 64 65 20 28 22 20 63 6d 64 6c 6e 20 22 29 mode (" cmdln ")
80f0: 20 61 74 20 22 28 63 6f 6d 6d 6f 6e 3a 68 75 6d at "(common:hum
8100: 61 6e 2d 74 69 6d 65 29 22 20 66 6f 72 20 22 61 an-time)" for "a
8110: 72 65 61 70 61 74 68 29 0a 09 20 20 20 20 3b 3b reapath).. ;;
8120: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
8130: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8140: 74 2a 20 22 49 4e 46 4f 3a 20 73 74 61 72 74 69 t* "INFO: starti
8150: 6e 67 20 73 65 72 76 65 72 20 61 74 20 22 20 28 ng server at " (
8160: 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d common:human-tim
8170: 65 29 29 0a 0a 09 20 20 20 20 28 73 79 73 74 65 e))... (syste
8180: 6d 20 63 6d 64 6c 6e 29 0a 09 20 20 20 20 3b 3b m cmdln).. ;;
8190: 20 3b 3b 20 75 73 65 20 62 65 6c 6f 77 20 74 6f ;; use below to
81a0: 20 67 6f 20 62 61 63 6b 20 74 6f 20 6e 62 66 61 go back to nbfa
81b0: 6b 65 20 2d 20 6e 62 66 61 6b 65 20 64 6f 65 73 ke - nbfake does
81c0: 20 63 61 75 73 65 20 74 72 6f 75 62 6c 65 20 2e cause trouble .
81d0: 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 65 74 65 .... ;; (sete
81e0: 6e 76 20 22 4e 42 46 41 4b 45 5f 51 55 49 45 54 nv "NBFAKE_QUIET
81f0: 22 20 22 79 65 73 22 29 20 3b 3b 20 42 55 47 3a " "yes") ;; BUG:
8200: 20 63 68 61 6e 67 65 20 74 6f 20 77 69 74 68 2d change to with-
8210: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
8220: 61 62 6c 65 20 2e 2e 2e 0a 09 20 20 20 20 3b 3b able ..... ;;
8230: 20 28 73 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 (setenv "NBFAKE
8240: 5f 4c 4f 47 22 20 6c 6f 67 66 69 6c 65 29 0a 09 _LOG" logfile)..
8250: 20 20 20 20 3b 3b 20 28 73 79 73 74 65 6d 20 28 ;; (system (
8260: 63 6f 6e 63 20 22 63 64 20 22 61 72 65 61 70 61 conc "cd "areapa
8270: 74 68 22 20 3b 20 6e 62 66 61 6b 65 20 22 20 63 th" ; nbfake " c
8280: 6d 64 6c 6e 29 29 0a 09 20 20 20 20 3b 3b 20 28 mdln)).. ;; (
8290: 75 6e 73 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 unsetenv "NBFAKE
82a0: 5f 51 55 49 45 54 22 29 0a 09 20 20 20 20 3b 3b _QUIET").. ;;
82b0: 20 28 75 6e 73 65 74 65 6e 76 20 22 4e 42 46 41 (unsetenv "NBFA
82c0: 4b 45 5f 4c 4f 47 22 29 0a 09 20 20 20 20 0a 09 KE_LOG").. ..
82d0: 20 20 20 20 3b 3b 28 70 6f 70 2d 64 69 72 65 63 ;;(pop-direc
82e0: 74 6f 72 79 29 0a 09 20 20 20 20 29 29 29 29 29 tory).. )))))
82f0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
8300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 63 ==========.;; tc
8340: 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 73 74 75 p connection stu
8350: 66 66 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ff.;;===========
8360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
83a0: 66 69 6e 64 20 61 20 70 6f 72 74 20 61 6e 64 20 find a port and
83b0: 73 74 61 72 74 20 74 63 70 2d 73 65 72 76 65 72 start tcp-server
83c0: 2e 20 54 68 69 73 20 6f 6e 6c 79 20 73 74 61 72 . This only star
83d0: 74 73 20 74 68 65 20 74 63 70 20 70 6f 72 74 69 ts the tcp porti
83e0: 6f 6e 20 6f 66 0a 3b 3b 20 74 68 65 20 73 65 72 on of.;; the ser
83f0: 76 65 72 2c 20 6c 6f 6f 6b 20 61 74 20 28 74 74 ver, look at (tt
8400: 3a 73 74 61 72 74 2d 73 65 72 76 65 72 20 2e 2e :start-server ..
8410: 2e 29 20 61 62 6f 76 65 20 66 6f 72 20 74 68 65 .) above for the
8420: 20 65 6e 74 72 79 20 70 6f 69 6e 74 0a 3b 3b 20 entry point.;;
8430: 66 6f 72 20 74 68 65 20 65 6e 74 69 72 65 20 73 for the entire s
8440: 65 72 76 65 72 20 73 79 73 74 65 6d 0a 3b 3b 0a erver system.;;.
8450: 28 64 65 66 69 6e 65 20 28 74 74 3a 73 74 61 72 (define (tt:star
8460: 74 2d 74 63 70 2d 73 65 72 76 65 72 20 74 74 64 t-tcp-server ttd
8470: 61 74 29 0a 20 20 28 73 65 74 75 70 2d 6c 69 73 at). (setup-lis
8480: 74 65 6e 65 72 2d 70 6f 72 74 6c 6f 67 67 65 72 tener-portlogger
8490: 20 74 74 64 61 74 29 20 3b 3b 20 73 65 74 20 75 ttdat) ;; set u
84a0: 70 20 74 63 70 2d 6c 69 73 74 65 6e 65 72 0a 20 p tcp-listener.
84b0: 20 28 6c 65 74 2a 20 28 28 73 6f 63 6b 65 74 20 (let* ((socket
84c0: 20 20 28 74 74 2d 73 6f 63 6b 65 74 20 20 74 74 (tt-socket tt
84d0: 64 61 74 29 29 0a 09 20 28 68 61 6e 64 6c 65 72 dat)).. (handler
84e0: 20 20 28 74 74 2d 68 61 6e 64 6c 65 72 20 74 74 (tt-handler tt
84f0: 64 61 74 29 29 20 3b 3b 20 74 68 65 20 68 61 6e dat)) ;; the han
8500: 64 6c 65 72 20 63 6f 6d 65 73 20 66 72 6f 6d 20 dler comes from
8510: 6f 75 72 20 63 6c 69 65 6e 74 20 73 65 74 74 69 our client setti
8520: 6e 67 20 61 20 68 61 6e 64 6c 65 72 20 66 75 6e ng a handler fun
8530: 63 74 69 6f 6e 0a 09 20 28 68 61 6e 64 6c 65 72 ction.. (handler
8540: 2d 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 29 -proc (lambda ()
8550: 0a 09 09 09 20 28 6c 65 74 2a 20 28 28 69 6e 64 .... (let* ((ind
8560: 61 74 20 20 20 20 20 20 20 20 20 28 64 65 73 65 at (dese
8570: 72 69 61 6c 69 7a 65 29 29 20 3b 3b 20 63 6f 75 rialize)) ;; cou
8580: 6c 64 20 75 73 65 3a 20 28 74 68 72 65 61 64 2d ld use: (thread-
8590: 74 65 72 6d 69 6e 61 74 65 21 20 28 63 75 72 72 terminate! (curr
85a0: 65 6e 74 2d 74 68 72 65 61 64 29 29 0a 09 09 09 ent-thread))....
85b0: 09 28 72 65 73 75 6c 74 20 20 20 20 20 20 20 20 .(result
85c0: 23 66 29 0a 09 09 09 09 28 65 78 6e 2d 72 65 73 #f).....(exn-res
85d0: 75 6c 74 20 20 20 20 23 66 29 0a 09 09 09 09 28 ult #f).....(
85e0: 73 74 64 6f 75 74 2d 72 65 73 75 6c 74 20 28 77 stdout-result (w
85f0: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 ith-output-to-st
8600: 72 69 6e 67 0a 09 09 09 09 09 09 20 28 6c 61 6d ring....... (lam
8610: 62 64 61 20 28 29 0a 09 09 09 09 09 09 20 20 20 bda ().......
8620: 28 6c 65 74 20 28 28 72 65 73 20 28 68 61 6e 64 (let ((res (hand
8630: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
8640: 09 09 09 09 09 20 20 20 20 20 20 20 65 78 6e 0a ..... exn.
8650: 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 6c ....... (l
8660: 65 74 2a 20 28 28 65 72 72 64 61 74 20 28 63 6f et* ((errdat (co
8670: 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 ndition->list ex
8680: 6e 29 29 29 0a 09 09 09 09 09 09 09 09 20 28 73 n)))......... (s
8690: 65 74 21 20 65 78 6e 2d 72 65 73 75 6c 74 20 65 et! exn-result e
86a0: 72 72 64 61 74 29 0a 09 09 09 09 09 09 09 09 20 rrdat).........
86b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
86c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
86d0: 2a 20 22 45 52 52 4f 52 3a 20 68 61 6e 64 6c 65 * "ERROR: handle
86e0: 72 20 65 78 63 65 70 74 69 6f 6e 2c 20 74 68 65 r exception, the
86f0: 73 65 20 61 72 65 20 62 61 64 2c 20 77 69 6c 6c se are bad, will
8700: 20 65 78 69 74 20 69 6e 20 66 69 76 65 20 73 65 exit in five se
8710: 63 6f 6e 64 73 2e 22 29 0a 09 09 09 09 09 09 09 conds.")........
8720: 09 20 28 70 70 20 65 72 72 64 61 74 20 2a 64 65 . (pp errdat *de
8730: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 fault-log-port*)
8740: 0a 09 09 09 09 09 09 09 09 20 3b 3b 20 74 68 65 ......... ;; the
8750: 73 65 20 61 72 65 20 61 6c 77 61 79 73 20 62 61 se are always ba
8760: 64 2c 20 73 65 74 20 75 70 20 61 6e 20 65 78 69 d, set up an exi
8770: 74 20 74 68 72 65 61 64 0a 09 09 09 09 09 09 09 t thread........
8780: 09 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 . (thread-start!
8790: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c (make-thread (l
87a0: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 09 09 ambda ()........
87b0: 20 20 20 20 20 20 09 09 09 09 20 20 20 20 20 20 ....
87c0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
87d0: 35 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 5)........
87e0: 09 09 09 09 20 20 20 20 20 20 20 28 65 78 69 74 .... (exit
87f0: 29 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 ))))........
8800: 20 20 20 23 66 29 0a 09 09 09 09 09 09 09 09 28 #f).........(
8810: 68 61 6e 64 6c 65 72 20 69 6e 64 61 74 29 20 3b handler indat) ;
8820: 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 70 72 ; this is the pr
8830: 6f 63 20 62 65 69 6e 67 20 63 61 6c 6c 65 64 20 oc being called
8840: 62 79 20 74 68 65 20 72 65 6d 6f 74 65 20 63 6c by the remote cl
8850: 69 65 6e 74 0a 09 09 09 09 09 09 09 09 29 29 29 ient.........)))
8860: 0a 09 09 09 09 09 09 20 20 20 20 20 28 73 65 74 ....... (set
8870: 21 20 72 65 73 75 6c 74 20 72 65 73 29 29 29 29 ! result res))))
8880: 29 0a 09 09 09 09 28 66 75 6c 6c 2d 72 65 73 75 ).....(full-resu
8890: 6c 74 20 20 20 20 28 6c 69 73 74 20 72 65 73 75 lt (list resu
88a0: 6c 74 20 65 78 6e 2d 72 65 73 75 6c 74 20 28 69 lt exn-result (i
88b0: 66 20 28 65 71 75 61 6c 3f 20 73 74 64 6f 75 74 f (equal? stdout
88c0: 2d 72 65 73 75 6c 74 20 22 22 29 20 23 66 20 73 -result "") #f s
88d0: 74 64 6f 75 74 2d 72 65 73 75 6c 74 29 29 29 29 tdout-result))))
88e0: 0a 09 09 09 20 20 20 28 68 61 6e 64 6c 65 2d 65 .... (handle-e
88f0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 20 20 xceptions....
8900: 20 20 20 20 65 78 6e 0a 09 09 09 20 20 20 20 20 exn....
8910: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 (begin....
8920: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
8930: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8940: 74 2a 20 22 53 65 72 69 61 6c 69 7a 61 74 69 6f t* "Serializatio
8950: 6e 20 66 61 69 6c 75 72 65 2e 20 66 75 6c 6c 2d n failure. full-
8960: 72 65 73 75 6c 74 3d 22 66 75 6c 6c 2d 72 65 73 result="full-res
8970: 75 6c 74 29 0a 09 09 09 20 20 20 20 20 20 20 28 ult).... (
8980: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 28 6d thread-start! (m
8990: 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
89a0: 64 61 20 28 29 0a 09 09 09 09 09 09 09 20 20 20 da ()........
89b0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
89c0: 20 35 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 5)........
89d0: 28 65 78 69 74 29 29 29 29 29 20 20 20 20 3b 3b (exit))))) ;;
89e0: 20 28 73 65 72 69 61 6c 69 7a 65 20 27 28 23 66 (serialize '(#f
89f0: 20 23 66 20 23 66 29 29 20 3b 3b 20 64 6f 65 73 #f #f)) ;; does
8a00: 6e 27 74 20 77 6f 72 6b 20 2d 20 74 68 65 20 66 n't work - the f
8a10: 69 72 73 74 20 63 61 6c 6c 20 74 6f 20 73 65 72 irst call to ser
8a20: 69 61 6c 69 7a 65 20 63 61 75 73 65 64 20 66 61 ialize caused fa
8a30: 69 6c 75 72 65 0a 09 09 09 20 20 20 20 20 28 73 ilure.... (s
8a40: 65 72 69 61 6c 69 7a 65 20 66 75 6c 6c 2d 72 65 erialize full-re
8a50: 73 75 6c 74 29 29 29 29 29 29 0a 20 20 20 20 28 sult)))))). (
8a60: 28 6d 61 6b 65 2d 74 63 70 2d 73 65 72 76 65 72 (make-tcp-server
8a70: 20 73 6f 63 6b 65 74 20 68 61 6e 64 6c 65 72 2d socket handler-
8a80: 70 72 6f 63 29 0a 20 20 20 20 20 23 66 20 3b 3b proc). #f ;;
8a90: 20 79 65 73 2c 20 73 65 6e 64 20 65 72 72 6f 72 yes, send error
8aa0: 20 6d 65 73 73 61 67 65 73 20 74 6f 20 73 74 64 messages to std
8ab0: 2d 65 72 72 0a 20 20 20 20 20 29 29 29 0a 0a 3b -err. )))..;
8ac0: 3b 20 63 72 65 61 74 65 20 61 20 74 63 70 20 6c ; create a tcp l
8ad0: 69 73 74 65 6e 65 72 20 61 6e 64 20 72 65 74 75 istener and retu
8ae0: 72 6e 20 61 20 70 6f 70 75 6c 61 74 65 64 20 75 rn a populated u
8af0: 64 61 74 20 73 74 72 75 63 74 20 77 69 74 68 0a dat struct with.
8b00: 3b 3b 20 6d 79 20 70 6f 72 74 2c 20 61 64 64 72 ;; my port, addr
8b10: 65 73 73 2c 20 68 6f 73 74 6e 61 6d 65 2c 20 70 ess, hostname, p
8b20: 69 64 20 65 74 63 2e 0a 3b 3b 20 72 65 74 75 72 id etc..;; retur
8b30: 6e 20 23 66 20 69 66 20 66 61 69 6c 20 74 6f 20 n #f if fail to
8b40: 66 69 6e 64 20 61 20 70 6f 72 74 20 74 6f 20 61 find a port to a
8b50: 6c 6c 6f 63 61 74 65 2e 0a 3b 3b 0a 3b 3b 20 20 llocate..;;.;;
8b60: 69 66 20 75 64 61 74 61 2d 69 6e 20 69 73 20 23 if udata-in is #
8b70: 66 20 63 72 65 61 74 65 20 74 68 65 20 72 65 63 f create the rec
8b80: 6f 72 64 0a 3b 3b 20 20 69 66 20 74 68 65 72 65 ord.;; if there
8b90: 20 69 73 20 61 6c 72 65 61 64 79 20 61 20 73 65 is already a se
8ba0: 72 76 2d 6c 69 73 74 65 6e 65 72 20 72 65 74 75 rv-listener retu
8bb0: 72 6e 20 74 68 65 20 75 64 61 74 61 0a 3b 3b 0a rn the udata.;;.
8bc0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 74 75 ;; (define (setu
8bd0: 70 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e 6e p-listener uconn
8be0: 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 70 6f 72 #!optional (por
8bf0: 74 20 34 32 34 32 29 29 0a 3b 3b 20 20 20 28 61 t 4242)).;; (a
8c00: 73 73 65 72 74 20 28 74 74 3f 20 75 63 6f 6e 6e ssert (tt? uconn
8c10: 29 20 22 46 41 54 41 4c 3a 20 73 65 74 75 70 2d ) "FATAL: setup-
8c20: 6c 69 73 74 65 6e 65 72 20 63 61 6c 6c 65 64 20 listener called
8c30: 77 69 74 68 20 77 72 6f 6e 67 20 73 74 72 75 63 with wrong struc
8c40: 74 20 22 75 63 6f 6e 6e 29 0a 3b 3b 20 20 20 28 t "uconn).;; (
8c50: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
8c60: 73 0a 3b 3b 20 20 20 20 65 78 6e 0a 3b 3b 20 20 s.;; exn.;;
8c70: 20 20 28 69 66 20 28 3c 20 70 6f 72 74 20 36 35 (if (< port 65
8c80: 35 33 35 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 535).;; (
8c90: 62 65 67 69 6e 0a 3b 3b 20 09 20 28 74 68 72 65 begin.;; . (thre
8ca0: 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 0a ad-sleep! 0.25).
8cb0: 3b 3b 20 09 20 28 73 65 74 75 70 2d 6c 69 73 74 ;; . (setup-list
8cc0: 65 6e 65 72 20 75 63 6f 6e 6e 20 28 2b 20 70 6f ener uconn (+ po
8cd0: 72 74 20 31 29 29 29 0a 3b 3b 20 20 20 20 20 20 rt 1))).;;
8ce0: 20 20 23 66 29 0a 3b 3b 20 20 20 20 28 63 6f 6e #f).;; (con
8cf0: 6e 65 63 74 2d 6c 69 73 74 65 6e 65 72 20 75 63 nect-listener uc
8d00: 6f 6e 6e 20 70 6f 72 74 29 29 29 0a 0a 28 64 65 onn port)))..(de
8d10: 66 69 6e 65 20 28 73 65 74 75 70 2d 6c 69 73 74 fine (setup-list
8d20: 65 6e 65 72 2d 70 6f 72 74 6c 6f 67 67 65 72 20 ener-portlogger
8d30: 75 63 6f 6e 6e 29 0a 20 20 28 6c 65 74 20 28 28 uconn). (let ((
8d40: 70 6f 72 74 20 28 70 6f 72 74 6c 6f 67 67 65 72 port (portlogger
8d50: 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 :open-run-close
8d60: 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 6e 64 2d portlogger:find-
8d70: 70 6f 72 74 29 29 29 0a 20 20 20 20 28 61 73 73 port))). (ass
8d80: 65 72 74 20 28 74 74 3f 20 75 63 6f 6e 6e 29 20 ert (tt? uconn)
8d90: 22 46 41 54 41 4c 3a 20 73 65 74 75 70 2d 6c 69 "FATAL: setup-li
8da0: 73 74 65 6e 65 72 20 63 61 6c 6c 65 64 20 77 69 stener called wi
8db0: 74 68 20 77 72 6f 6e 67 20 73 74 72 75 63 74 20 th wrong struct
8dc0: 22 75 63 6f 6e 6e 29 0a 20 20 20 20 28 68 61 6e "uconn). (han
8dd0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
8de0: 65 78 6e 0a 20 20 20 20 20 20 28 69 66 20 28 3c exn. (if (<
8df0: 20 70 6f 72 74 20 36 35 35 33 35 29 0a 09 20 20 port 65535)..
8e00: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 70 6f 72 (begin.. (por
8e10: 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e tlogger:open-run
8e20: 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 -close portlogge
8e30: 72 3a 73 65 74 2d 66 61 69 6c 65 64 20 70 6f 72 r:set-failed por
8e40: 74 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d t).. (thread-
8e50: 73 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 20 20 sleep! 0.25)..
8e60: 20 20 28 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 (setup-listene
8e70: 72 2d 70 6f 72 74 6c 6f 67 67 65 72 20 75 63 6f r-portlogger uco
8e80: 6e 6e 29 29 0a 09 20 20 23 66 29 0a 20 20 20 20 nn)).. #f).
8e90: 20 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 74 65 (connect-liste
8ea0: 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 29 29 ner uconn port))
8eb0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e ))..(define (con
8ec0: 6e 65 63 74 2d 6c 69 73 74 65 6e 65 72 20 75 63 nect-listener uc
8ed0: 6f 6e 6e 20 70 6f 72 74 29 0a 20 20 3b 3b 20 28 onn port). ;; (
8ee0: 74 63 70 2d 6c 69 73 74 65 6e 65 72 2d 73 6f 63 tcp-listener-soc
8ef0: 6b 65 74 20 4c 49 53 54 45 4e 45 52 29 28 73 6f ket LISTENER)(so
8f00: 63 6b 65 74 2d 6e 61 6d 65 20 73 6f 29 0a 20 20 cket-name so).
8f10: 3b 3b 20 73 6f 63 6b 61 64 64 72 2d 61 64 64 72 ;; sockaddr-addr
8f20: 65 73 73 2c 20 73 6f 63 6b 61 64 64 72 2d 70 6f ess, sockaddr-po
8f30: 72 74 2c 20 73 6f 63 6b 61 64 64 72 2d 3e 73 74 rt, sockaddr->st
8f40: 72 69 6e 67 0a 20 20 28 6c 65 74 2a 20 28 28 74 ring. (let* ((t
8f50: 6c 73 6e 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 lsn (tcp-listen
8f60: 70 6f 72 74 20 31 30 30 30 30 20 23 66 29 29 20 port 10000 #f))
8f70: 3b 3b 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 54 ;; (tcp-listen T
8f80: 43 50 50 4f 52 54 20 5b 42 41 43 4b 4c 4f 47 20 CPPORT [BACKLOG
8f90: 5b 48 4f 53 54 5d 5d 29 0a 09 20 28 61 64 64 72 [HOST]]).. (addr
8fa0: 20 20 28 74 74 3a 67 65 74 2d 62 65 73 74 2d 67 (tt:get-best-g
8fb0: 75 65 73 73 2d 61 64 64 72 65 73 73 20 28 67 65 uess-address (ge
8fc0: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 29 20 t-host-name))))
8fd0: 3b 3b 20 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d ;; (get-my-best-
8fe0: 61 64 64 72 65 73 73 29 29 29 20 3b 3b 20 28 68 address))) ;; (h
8ff0: 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 ostinfo-addresse
9000: 73 20 28 68 6f 73 74 2d 69 6e 66 6f 72 6d 61 74 s (host-informat
9010: 69 6f 6e 20 28 63 75 72 72 65 6e 74 2d 68 6f 73 ion (current-hos
9020: 74 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 74 74 tname))). (tt
9030: 2d 70 6f 72 74 2d 73 65 74 21 20 20 20 20 20 20 -port-set!
9040: 75 63 6f 6e 6e 20 70 6f 72 74 29 0a 20 20 20 20 uconn port).
9050: 28 74 74 2d 68 6f 73 74 2d 73 65 74 21 20 20 20 (tt-host-set!
9060: 20 20 20 75 63 6f 6e 6e 20 61 64 64 72 29 0a 20 uconn addr).
9070: 20 20 20 28 74 74 2d 68 6f 73 74 2d 70 6f 72 74 (tt-host-port
9080: 2d 73 65 74 21 20 75 63 6f 6e 6e 20 28 63 6f 6e -set! uconn (con
9090: 63 20 61 64 64 72 22 3a 22 70 6f 72 74 29 29 0a c addr":"port)).
90a0: 20 20 20 20 28 74 74 2d 73 6f 63 6b 65 74 2d 73 (tt-socket-s
90b0: 65 74 21 20 20 20 20 75 63 6f 6e 6e 20 74 6c 73 et! uconn tls
90c0: 6e 29 0a 20 20 20 20 75 63 6f 6e 6e 29 29 0a 0a n). uconn))..
90d0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
90e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9110: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 75 74 69 6c ========.;; util
9120: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
9130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 ==========..;; G
9170: 65 6e 65 72 61 74 65 20 61 20 75 6e 69 71 75 65 enerate a unique
9180: 20 73 69 67 6e 61 74 75 72 65 20 66 6f 72 20 74 signature for t
9190: 68 69 73 20 73 65 72 76 65 72 0a 28 64 65 66 69 his server.(defi
91a0: 6e 65 20 28 74 74 3a 6d 6b 2d 73 69 67 6e 61 74 ne (tt:mk-signat
91b0: 75 72 65 20 61 72 65 61 70 61 74 68 29 0a 20 20 ure areapath).
91c0: 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d (message-digest-
91d0: 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d string (md5-prim
91e0: 69 74 69 76 65 29 20 0a 09 09 09 20 28 77 69 74 itive) .... (wit
91f0: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 h-output-to-stri
9200: 6e 67 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 61 ng.... (lambda
9210: 20 28 29 0a 09 09 09 20 20 20 20 20 28 77 72 69 ().... (wri
9220: 74 65 20 28 6c 69 73 74 20 61 72 65 61 70 61 74 te (list areapat
9230: 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 h.
9240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9250: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 (cur
9260: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
9270: 0a 09 09 09 09 09 20 20 28 61 72 67 76 29 29 29 ...... (argv)))
9280: 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ))))...(define (
9290: 74 74 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 tt:get-best-gues
92a0: 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 s-address hostna
92b0: 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 me). (let ((res
92c0: 20 23 66 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 #f)). (for-e
92d0: 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
92e0: 61 20 28 61 64 72 29 0a 20 20 20 20 20 20 20 28 a (adr). (
92f0: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 if (not (eq? (u8
9300: 76 65 63 74 6f 72 2d 72 65 66 20 61 64 72 20 30 vector-ref adr 0
9310: 29 20 31 32 37 29 29 0a 09 20 20 20 28 73 65 74 ) 127)).. (set
9320: 21 20 72 65 73 20 61 64 72 29 29 29 0a 20 20 20 ! res adr))).
9330: 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 ;; NOTE: This
9340: 63 61 6e 20 66 61 69 6c 20 77 68 65 6e 20 74 68 can fail when th
9350: 65 72 65 20 69 73 20 6e 6f 20 6d 65 6e 74 69 6f ere is no mentio
9360: 6e 20 6f 66 20 74 68 65 20 68 6f 73 74 20 69 6e n of the host in
9370: 20 2f 65 74 63 2f 68 6f 73 74 73 2e 20 46 49 58 /etc/hosts. FIX
9380: 4d 45 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d ME. (vector-
9390: 3e 6c 69 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d >list (hostinfo-
93a0: 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 74 6e addresses (hostn
93b0: 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 68 6f ame->hostinfo ho
93c0: 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 28 stname)))). (
93d0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
93e0: 73 65 20 0a 20 20 20 20 20 28 6d 61 70 20 6e 75 se . (map nu
93f0: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 0a 09 20 20 mber->string..
9400: 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 74 0a (u8vector->list.
9410: 09 20 20 20 28 69 66 20 72 65 73 20 72 65 73 20 . (if res res
9420: 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f (hostname->ip ho
9430: 73 74 6e 61 6d 65 29 29 29 29 20 22 2e 22 29 29 stname)))) "."))
9440: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 67 )..(define (tt:g
9450: 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 et-servinfo-dir
9460: 61 72 65 61 70 61 74 68 29 0a 20 20 28 6c 65 74 areapath). (let
9470: 2a 20 28 28 73 70 61 74 68 20 28 63 6f 6e 63 20 * ((spath (conc
9480: 61 72 65 61 70 61 74 68 22 2f 2e 73 65 72 76 69 areapath"/.servi
9490: 6e 66 6f 22 29 29 29 0a 20 20 20 20 28 69 66 20 nfo"))). (if
94a0: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
94b0: 73 3f 20 73 70 61 74 68 29 29 0a 09 28 63 72 65 s? spath))..(cre
94c0: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 73 70 ate-directory sp
94d0: 61 74 68 20 23 74 29 29 0a 20 20 20 20 73 70 61 ath #t)). spa
94e0: 74 68 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d th))..;;========
94f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
9530: 3b 20 6e 65 74 77 6f 72 6b 20 75 74 69 6c 69 74 ; network utilit
9540: 69 65 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ies.;;==========
9550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
9590: 20 4e 4f 54 45 3a 20 4c 6f 6f 6b 20 61 74 20 61 NOTE: Look at a
95a0: 64 64 72 65 73 73 2d 69 6e 66 6f 20 65 67 67 20 ddress-info egg
95b0: 61 73 20 61 6c 74 65 72 6e 61 74 69 76 65 20 74 as alternative t
95c0: 6f 20 73 6f 6d 65 20 6f 66 20 74 68 69 73 0a 0a o some of this..
95d0: 28 64 65 66 69 6e 65 20 28 72 61 74 65 2d 69 70 (define (rate-ip
95e0: 20 69 70 61 64 64 72 29 0a 20 20 28 72 65 67 65 ipaddr). (rege
95f0: 78 2d 63 61 73 65 20 69 70 61 64 64 72 0a 20 20 x-case ipaddr.
9600: 20 20 28 20 22 5e 31 32 37 5c 5c 2e 2e 2a 22 20 ( "^127\\..*"
9610: 5f 20 30 20 29 0a 20 20 20 20 28 20 22 5e 28 31 _ 0 ). ( "^(1
9620: 30 5c 5c 2e 30 7c 31 39 32 5c 5c 2e 31 36 38 29 0\\.0|192\\.168)
9630: 5c 5c 2e 2e 2a 22 20 5f 20 31 20 29 0a 20 20 20 \\..*" _ 1 ).
9640: 20 28 20 65 6c 73 65 20 32 20 29 20 29 29 0a 0a ( else 2 ) ))..
9650: 3b 3b 20 43 68 61 6e 67 65 20 74 68 69 73 20 74 ;; Change this t
9660: 6f 20 62 69 61 73 20 66 6f 72 20 61 64 64 72 65 o bias for addre
9670: 73 73 65 73 20 77 69 74 68 20 61 20 72 65 61 73 sses with a reas
9680: 6f 6e 61 62 6c 65 20 62 72 6f 61 64 63 61 73 74 onable broadcast
9690: 20 76 61 6c 75 65 3f 0a 3b 3b 0a 28 64 65 66 69 value?.;;.(defi
96a0: 6e 65 20 28 69 70 2d 70 72 65 66 2d 6c 65 73 73 ne (ip-pref-less
96b0: 3f 20 61 20 62 29 0a 20 20 28 3e 20 28 72 61 74 ? a b). (> (rat
96c0: 65 2d 69 70 20 61 29 20 28 72 61 74 65 2d 69 70 e-ip a) (rate-ip
96d0: 20 62 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 b)))..(define (
96e0: 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 get-my-best-addr
96f0: 65 73 73 29 0a 20 20 28 6c 65 74 20 28 28 61 6c ess). (let ((al
9700: 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 20 28 l-my-addresses (
9710: 67 65 74 2d 61 6c 6c 2d 69 70 73 29 29 29 0a 20 get-all-ips))).
9720: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
9730: 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 64 64 null? all-my-add
9740: 72 65 73 73 65 73 29 0a 20 20 20 20 20 20 28 67 resses). (g
9750: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 20 20 et-host-name))
9760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9780: 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 69 6e ;; no in
9790: 74 65 72 66 61 63 65 73 3f 0a 20 20 20 20 20 28 terfaces?. (
97a0: 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 61 6c 6c (eq? (length all
97b0: 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 20 31 -my-addresses) 1
97c0: 29 0a 20 20 20 20 20 20 28 63 61 72 20 61 6c 6c ). (car all
97d0: 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 29 20 -my-addresses))
97e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97f0: 20 20 20 20 20 3b 3b 20 6f 6e 6c 79 20 6f 6e 65 ;; only one
9800: 20 74 6f 20 63 68 6f 6f 73 65 20 66 72 6f 6d 2c to choose from,
9810: 20 6a 75 73 74 20 67 6f 20 77 69 74 68 20 69 74 just go with it
9820: 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 . (else.
9830: 20 20 28 63 61 72 20 28 73 6f 72 74 20 61 6c 6c (car (sort all
9840: 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 20 69 70 -my-addresses ip
9850: 2d 70 72 65 66 2d 6c 65 73 73 3f 29 29 29 29 29 -pref-less?)))))
9860: 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d )..(define (get-
9870: 61 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 29 0a all-ips-sorted).
9880: 20 20 28 73 6f 72 74 20 28 67 65 74 2d 61 6c 6c (sort (get-all
9890: 2d 69 70 73 29 20 69 70 2d 70 72 65 66 2d 6c 65 -ips) ip-pref-le
98a0: 73 73 3f 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ss?))..(define (
98b0: 67 65 74 2d 61 6c 6c 2d 69 70 73 29 0a 20 20 28 get-all-ips). (
98c0: 6d 61 70 20 61 64 64 72 65 73 73 2d 69 6e 66 6f map address-info
98d0: 2d 68 6f 73 74 0a 20 20 20 20 20 20 20 28 66 69 -host. (fi
98e0: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
98f0: 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 61 64 64 ... (equal? (add
9900: 72 65 73 73 2d 69 6e 66 6f 2d 74 79 70 65 20 78 ress-info-type x
9910: 29 20 22 74 63 70 22 29 29 0a 09 20 20 20 20 20 ) "tcp"))..
9920: 20 20 28 61 64 64 72 65 73 73 2d 69 6e 66 6f 73 (address-infos
9930: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
9940: 29 29 29 29 0a 0a 29 0a ))))..).