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 6c 65 74 2a 20 28 28 63 6f 6e d). (let* ((con
0c60: 6e 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 n (hash-table-re
0c70: 66 2f 64 65 66 61 75 6c 74 20 28 74 74 2d 63 6f f/default (tt-co
0c80: 6e 6e 73 20 74 74 64 61 74 29 20 64 62 66 6e 61 nns ttdat) dbfna
0c90: 6d 65 20 23 66 29 29 0a 09 20 28 73 65 72 76 65 me #f)).. (serve
0ca0: 72 2d 73 74 61 72 74 2d 70 72 6f 63 20 28 6c 61 r-start-proc (la
0cb0: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 mbda ()....
0cc0: 20 28 74 74 3a 73 65 72 76 65 72 2d 70 72 6f 63 (tt:server-proc
0cd0: 65 73 73 2d 72 75 6e 0a 09 09 09 20 20 20 20 20 ess-run....
0ce0: 20 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 74 (tt-areapath t
0cf0: 74 64 61 74 29 0a 09 09 09 20 20 20 20 20 20 20 tdat)....
0d00: 74 65 73 74 73 75 69 74 65 20 3b 3b 20 28 64 62 testsuite ;; (db
0d10: 66 69 6c 65 3a 74 65 73 74 73 75 69 74 65 2d 6e file:testsuite-n
0d20: 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 20 28 ame).... (
0d30: 63 6f 6d 6d 6f 6e 3a 66 69 6e 64 2d 6c 6f 63 61 common:find-loca
0d40: 6c 2d 6d 65 67 61 74 65 73 74 29 0a 09 09 09 20 l-megatest)....
0d50: 20 20 20 20 20 20 72 75 6e 2d 69 64 29 29 29 29 run-id))))
0d60: 0a 20 20 20 20 28 69 66 20 63 6f 6e 6e 0a 09 28 . (if conn..(
0d70: 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 begin .
0d80: 20 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ; (debug:print-
0d90: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
0da0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 6c 72 65 61 log-port* "alrea
0db0: 64 79 20 63 6f 6e 6e 65 63 74 65 64 20 74 6f 20 dy connected to
0dc0: 74 68 65 20 73 65 72 76 65 72 22 29 0a 20 20 20 the server").
0dd0: 20 20 20 20 20 20 20 20 63 6f 6e 6e 29 20 3b 3b conn) ;;
0de0: 20 77 65 20 61 72 65 20 61 6c 72 65 61 64 79 20 we are already
0df0: 63 6f 6e 6e 65 63 74 65 64 20 74 6f 20 74 68 65 connected to the
0e00: 20 73 65 72 76 65 72 0a 09 28 6c 65 74 2a 20 28 server..(let* (
0e10: 28 73 64 61 74 20 28 74 74 3a 67 65 74 2d 63 75 (sdat (tt:get-cu
0e20: 72 72 65 6e 74 2d 73 65 72 76 65 72 2d 69 6e 66 rrent-server-inf
0e30: 6f 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 o ttdat dbfname)
0e40: 29 29 0a 09 20 20 28 6d 61 74 63 68 20 73 64 61 )).. (match sda
0e50: 74 0a 09 20 20 20 20 28 28 68 6f 73 74 20 70 6f t.. ((host po
0e60: 72 74 20 73 74 61 72 74 2d 74 69 6d 65 20 73 65 rt start-time se
0e70: 72 76 65 72 2d 69 64 20 70 69 64 20 64 62 66 6e rver-id pid dbfn
0e80: 61 6d 65 32 20 73 65 72 76 69 6e 66 66 69 6c 65 ame2 servinffile
0e90: 29 0a 09 20 20 20 20 20 28 61 73 73 65 72 74 20 ).. (assert
0ea0: 28 65 71 75 61 6c 3f 20 64 62 66 6e 61 6d 65 20 (equal? dbfname
0eb0: 64 62 66 6e 61 6d 65 32 29 20 22 46 41 54 41 4c dbfname2) "FATAL
0ec0: 3a 20 72 65 61 64 20 73 65 72 76 65 72 20 69 6e : read server in
0ed0: 66 6f 20 66 72 6f 6d 20 77 72 6f 6e 67 20 66 69 fo from wrong fi
0ee0: 6c 65 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 le.").
0ef0: 20 20 20 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 ;(debug:print
0f00: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
0f10: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 6e 20 6d -log-port* "in m
0f20: 61 74 63 68 20 73 65 72 76 69 6e 66 66 69 6c 65 atch servinffile
0f30: 3a 22 20 73 65 72 76 69 6e 66 66 69 6c 65 29 0a :" servinffile).
0f40: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 68 6f . (let* ((ho
0f50: 73 74 2d 70 6f 72 74 20 28 63 6f 6e 63 20 68 6f st-port (conc ho
0f60: 73 74 22 3a 22 70 6f 72 74 29 29 0a 09 09 20 20 st":"port))...
0f70: 20 20 28 63 6f 6e 6e 20 28 6d 61 6b 65 2d 74 74 (conn (make-tt
0f80: 2d 63 6f 6e 6e 0a 09 09 09 20 20 20 68 6f 73 74 -conn.... host
0f90: 3a 20 68 6f 73 74 0a 09 09 09 20 20 20 70 6f 72 : host.... por
0fa0: 74 3a 20 70 6f 72 74 0a 09 09 09 20 20 20 68 6f t: port.... ho
0fb0: 73 74 2d 70 6f 72 74 3a 20 68 6f 73 74 2d 70 6f st-port: host-po
0fc0: 72 74 0a 09 09 09 20 20 20 64 62 66 6e 61 6d 65 rt.... dbfname
0fd0: 3a 20 64 62 66 6e 61 6d 65 0a 09 09 09 20 20 20 : dbfname....
0fe0: 73 65 72 76 69 6e 66 2d 66 69 6c 65 3a 20 73 65 servinf-file: se
0ff0: 72 76 69 6e 66 66 69 6c 65 0a 09 09 09 20 20 20 rvinffile....
1000: 73 65 72 76 65 72 2d 69 64 3a 20 73 65 72 76 65 server-id: serve
1010: 72 2d 69 64 0a 09 09 09 20 20 20 73 65 72 76 65 r-id.... serve
1020: 72 2d 73 74 61 72 74 3a 20 73 74 61 72 74 2d 74 r-start: start-t
1030: 69 6d 65 0a 09 09 09 20 20 20 70 69 64 3a 20 70 ime.... pid: p
1040: 69 64 29 29 29 0a 09 20 20 20 20 20 20 20 3b 3b id))).. ;;
1050: 20 76 65 72 69 66 79 20 77 65 20 63 61 6e 20 74 verify we can t
1060: 61 6c 6b 20 74 6f 20 74 68 69 73 20 73 65 72 76 alk to this serv
1070: 65 72 0a 09 20 20 20 20 20 20 20 28 6c 65 74 2a er.. (let*
1080: 20 28 28 70 69 6e 67 2d 72 65 73 20 28 74 74 3a ((ping-res (tt:
1090: 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 73 ping host port s
10a0: 65 72 76 65 72 2d 69 64 29 29 29 0a 20 20 20 20 erver-id))).
10b0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 20 28 64 ; (d
10c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
10d0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
10e0: 6f 72 74 2a 20 22 70 69 6e 67 2d 72 65 73 3a 22 ort* "ping-res:"
10f0: 20 70 69 6e 67 2d 72 65 73 29 0a 09 09 20 28 63 ping-res)... (c
1100: 61 73 65 20 70 69 6e 67 2d 72 65 73 0a 09 09 20 ase ping-res...
1110: 20 20 28 28 72 75 6e 6e 69 6e 67 29 0a 09 09 20 ((running)...
1120: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
1130: 65 74 21 20 28 74 74 2d 63 6f 6e 6e 73 20 74 74 et! (tt-conns tt
1140: 64 61 74 29 20 64 62 66 6e 61 6d 65 20 63 6f 6e dat) dbfname con
1150: 6e 29 20 3b 3b 3b 20 69 73 20 74 68 69 73 20 6f n) ;;; is this o
1160: 6b 20 74 6f 20 73 61 76 65 20 62 65 66 6f 72 65 k to save before
1170: 20 76 61 6c 69 64 61 74 69 6e 67 20 74 68 61 74 validating that
1180: 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 the connection
1190: 69 73 20 67 6f 6f 64 3f 0a 09 09 20 20 20 20 63 is good?... c
11a0: 6f 6e 6e 29 0a 09 09 20 20 20 28 28 73 74 61 72 onn)... ((star
11b0: 74 69 6e 67 29 0a 09 09 20 20 20 20 28 74 68 72 ting)... (thr
11c0: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 0a ead-sleep! 0.5).
11d0: 09 09 20 20 20 20 28 74 74 3a 63 6c 69 65 6e 74 .. (tt:client
11e0: 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 -connect-to-serv
11f0: 65 72 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 er ttdat dbfname
1200: 20 72 75 6e 2d 69 64 20 74 65 73 74 73 75 69 74 run-id testsuit
1210: 65 29 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 e))... (else..
1220: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 63 75 72 . (let* ((cur
1230: 72 2d 73 65 63 73 20 28 63 75 72 72 65 6e 74 2d r-secs (current-
1240: 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 20 20 20 seconds)))...
1250: 20 20 20 3b 3b 20 72 6d 20 74 68 65 20 28 6c 61 ;; rm the (la
1260: 73 74 20 73 65 72 76 65 72 29 20 77 6f 75 6c 64 st server) would
1270: 20 67 6f 20 68 65 72 65 0a 09 09 20 20 20 20 20 go here...
1280: 20 28 69 66 20 28 3e 20 28 2d 20 63 75 72 72 2d (if (> (- curr-
1290: 73 65 63 73 20 28 74 74 2d 6c 61 73 74 2d 73 65 secs (tt-last-se
12a0: 72 76 2d 73 74 61 72 74 20 74 74 64 61 74 29 29 rv-start ttdat))
12b0: 20 31 30 29 0a 09 09 09 20 20 28 62 65 67 69 6e 10).... (begin
12c0: 0a 09 09 09 20 20 20 20 28 74 74 2d 6c 61 73 74 .... (tt-last
12d0: 2d 73 65 72 76 2d 73 74 61 72 74 2d 73 65 74 21 -serv-start-set!
12e0: 20 74 74 64 61 74 20 63 75 72 72 2d 73 65 63 73 ttdat curr-secs
12f0: 29 0a 09 09 09 20 20 20 20 28 73 65 72 76 65 72 ).... (server
1300: 2d 73 74 61 72 74 2d 70 72 6f 63 29 29 29 20 3b -start-proc))) ;
1310: 3b 20 73 74 61 72 74 20 73 65 72 76 65 72 20 69 ; start server i
1320: 66 20 33 30 20 73 65 63 20 73 69 6e 63 65 20 6c f 30 sec since l
1330: 61 73 74 20 61 74 74 65 6d 70 74 0a 09 09 20 20 ast attempt...
1340: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
1350: 70 21 20 31 29 0a 09 09 20 20 20 20 20 20 28 74 p! 1)... (t
1360: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
1370: 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 64 61 74 -to-server ttdat
1380: 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 dbfname run-id
1390: 74 65 73 74 73 75 69 74 65 29 29 29 29 29 29 29 testsuite)))))))
13a0: 0a 09 20 20 20 20 28 65 6c 73 65 20 3b 3b 20 6e .. (else ;; n
13b0: 6f 20 67 6f 6f 64 20 73 65 72 76 65 72 20 66 6f o good server fo
13c0: 75 6e 64 2c 20 69 66 20 68 61 76 65 6e 27 74 20 und, if haven't
13d0: 73 74 61 72 74 65 64 20 73 65 72 76 65 72 20 69 started server i
13e0: 6e 20 3e 20 35 20 73 65 63 73 2c 20 73 74 61 72 n > 5 secs, star
13f0: 74 20 61 6e 6f 74 68 65 72 0a 09 20 20 20 20 20 t another..
1400: 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 (if (> (- (curre
1410: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 74 74 2d nt-seconds) (tt-
1420: 6c 61 73 74 2d 73 65 72 76 2d 73 74 61 72 74 20 last-serv-start
1430: 74 74 64 61 74 29 29 20 35 29 20 3b 3b 20 42 55 ttdat)) 5) ;; BU
1440: 47 20 2d 20 67 72 6f 77 20 74 68 69 73 20 6e 75 G - grow this nu
1450: 6d 62 65 72 20 72 65 61 6c 6c 79 20 64 6f 20 6e mber really do n
1460: 6f 74 20 77 61 6e 74 20 74 6f 20 73 77 61 6d 70 ot want to swamp
1470: 20 74 68 65 20 6d 61 63 68 69 6e 65 20 77 69 74 the machine wit
1480: 68 20 73 65 72 76 65 72 73 0a 09 09 20 28 62 65 h servers... (be
1490: 67 69 6e 0a 09 09 20 20 20 28 64 65 62 75 67 3a gin... (debug:
14a0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
14b0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
14c0: 22 4e 6f 20 73 65 72 76 65 72 20 66 6f 75 6e 64 "No server found
14d0: 2e 20 53 74 61 72 74 69 6e 67 20 6f 6e 65 20 66 . Starting one f
14e0: 6f 72 20 72 75 6e 2d 69 64 20 22 72 75 6e 2d 69 or run-id "run-i
14f0: 64 22 20 69 6e 20 64 62 66 69 6c 65 20 22 64 62 d" in dbfile "db
1500: 66 6e 61 6d 65 29 0a 09 09 20 20 20 28 73 65 72 fname)... (ser
1510: 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 29 0a ver-start-proc).
1520: 09 09 20 20 20 28 74 74 2d 6c 61 73 74 2d 73 65 .. (tt-last-se
1530: 72 76 2d 73 74 61 72 74 2d 73 65 74 21 20 74 74 rv-start-set! tt
1540: 64 61 74 20 28 63 75 72 72 65 6e 74 2d 73 65 63 dat (current-sec
1550: 6f 6e 64 73 29 29 29 29 0a 09 20 20 20 20 20 28 onds)))).. (
1560: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
1570: 0a 09 20 20 20 20 20 28 74 74 3a 63 6c 69 65 6e .. (tt:clien
1580: 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 t-connect-to-ser
1590: 76 65 72 20 74 74 64 61 74 20 64 62 66 6e 61 6d ver ttdat dbfnam
15a0: 65 20 72 75 6e 2d 69 64 20 74 65 73 74 73 75 69 e run-id testsui
15b0: 74 65 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 te)))))))..(defi
15c0: 6e 65 20 28 74 74 3a 70 69 6e 67 20 68 6f 73 74 ne (tt:ping host
15d0: 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 20 port server-id
15e0: 23 21 6f 70 74 69 6f 6e 61 6c 20 28 74 72 69 65 #!optional (trie
15f0: 73 2d 6c 65 66 74 20 35 29 29 0a 20 20 28 6c 65 s-left 5)). (le
1600: 74 2a 20 20 28 28 72 65 73 20 20 20 20 20 20 28 t* ((res (
1610: 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d tt:send-receive-
1620: 64 69 72 65 63 74 20 68 6f 73 74 20 70 6f 72 74 direct host port
1630: 20 60 28 70 69 6e 67 20 23 66 20 23 66 20 23 66 `(ping #f #f #f
1640: 29 20 70 69 6e 67 2d 6d 6f 64 65 3a 20 23 74 29 ) ping-mode: #t)
1650: 29 20 3b 3b 20 70 6c 65 61 73 65 20 73 65 6e 64 ) ;; please send
1660: 20 6d 65 20 79 6f 75 72 20 73 65 72 76 65 72 2d me your server-
1670: 69 64 0a 09 20 20 28 74 72 79 2d 61 67 61 69 6e id.. (try-again
1680: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 (lambda ()...
1690: 20 20 20 20 20 28 69 66 20 28 3e 20 74 72 69 65 (if (> trie
16a0: 73 2d 6c 65 66 74 20 30 29 0a 09 09 09 20 20 20 s-left 0)....
16b0: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 28 (begin.... (
16c0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
16d0: 0a 09 09 09 20 20 20 20 20 28 74 74 3a 70 69 6e .... (tt:pin
16e0: 67 20 68 6f 73 74 20 70 6f 72 74 20 73 65 72 76 g host port serv
16f0: 65 72 2d 69 64 20 28 2d 20 74 72 69 65 73 2d 6c er-id (- tries-l
1700: 65 66 74 20 31 29 29 29 0a 09 09 09 20 20 20 23 eft 1))).... #
1710: 66 29 29 29 29 0a 20 20 20 20 3b 3b 0a 20 20 20 f)))). ;;.
1720: 20 3b 3b 20 6e 65 65 64 20 74 77 6f 20 74 68 72 ;; need two thr
1730: 65 61 64 73 2c 20 6f 6e 65 20 61 20 35 20 73 65 eads, one a 5 se
1740: 63 6f 6e 64 20 74 69 6d 65 72 0a 20 20 20 20 3b cond timer. ;
1750: 3b 0a 20 20 20 20 28 6d 61 74 63 68 20 72 65 73 ;. (match res
1760: 0a 20 20 20 20 20 20 28 28 73 74 61 74 75 73 20 . ((status
1770: 65 72 72 6d 73 67 20 72 65 73 75 6c 74 20 6d 65 errmsg result me
1780: 74 61 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 ta). (if (
1790: 65 71 75 61 6c 3f 20 72 65 73 75 6c 74 20 73 65 equal? result se
17a0: 72 76 65 72 2d 69 64 29 0a 09 20 20 20 28 6c 65 rver-id).. (le
17b0: 74 2a 20 28 28 73 65 72 76 65 72 2d 73 74 61 74 t* ((server-stat
17c0: 65 20 28 61 6c 69 73 74 2d 72 65 66 20 27 73 73 e (alist-ref 'ss
17d0: 74 61 74 65 20 6d 65 74 61 29 29 29 0a 09 20 20 tate meta)))..
17e0: 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
17f0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1800: 67 2d 70 6f 72 74 2a 20 22 50 69 6e 67 20 74 6f g-port* "Ping to
1810: 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 20 73 "host":"port" s
1820: 75 63 63 65 73 73 66 75 6c 2e 22 29 0a 09 20 20 uccessful.")..
1830: 20 20 20 28 6f 72 20 73 65 72 76 65 72 2d 73 74 (or server-st
1840: 61 74 65 20 27 75 6e 6b 29 29 20 3b 3b 20 74 68 ate 'unk)) ;; th
1850: 65 6e 20 77 65 20 61 72 65 20 67 6f 6f 64 0a 09 en we are good..
1860: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
1870: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1880: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1890: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 65 72 76 * "WARNING: serv
18a0: 65 72 2d 69 64 20 64 6f 65 73 20 6e 6f 74 20 6d er-id does not m
18b0: 61 74 63 68 2c 20 65 78 70 65 63 74 65 64 3a 20 atch, expected:
18c0: 22 73 65 72 76 65 72 2d 69 64 22 2c 20 67 6f 74 "server-id", got
18d0: 3a 20 22 72 65 73 75 6c 74 29 0a 09 20 20 20 20 : "result)..
18e0: 20 23 66 29 29 29 0a 20 20 20 20 20 20 28 65 6c #f))). (el
18f0: 73 65 0a 20 20 20 20 20 20 20 3b 3b 20 28 64 65 se. ;; (de
1900: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
1910: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1920: 72 65 73 20 6e 6f 74 20 69 6e 20 66 6f 72 6d 20 res not in form
1930: 28 73 74 61 74 75 73 20 65 72 72 6d 73 67 20 72 (status errmsg r
1940: 65 73 75 6c 74 20 6d 65 74 61 29 2c 20 67 6f 74 esult meta), got
1950: 3a 20 22 72 65 73 29 0a 20 20 20 20 20 20 20 28 : "res). (
1960: 74 72 79 2d 61 67 61 69 6e 29 29 29 29 29 0a 0a try-again)))))..
1970: 3b 3b 20 63 6c 69 65 6e 74 20 73 69 64 65 20 68 ;; client side h
1980: 61 6e 64 6c 65 72 0a 3b 3b 0a 3b 3b 28 74 74 3a andler.;;.;;(tt:
1990: 68 61 6e 64 6c 65 72 20 23 3c 74 74 3e 20 67 65 handler #<tt> ge
19a0: 74 2d 6b 65 79 73 20 23 66 20 28 29 20 32 20 23 t-keys #f () 2 #
19b0: 66 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 64 61 f "/home/matt/da
19c0: 74 61 2f 6d 65 67 61 74 65 73 74 2f 65 78 74 2d ta/megatest/ext-
19d0: 74 65 73 74 73 22 20 23 66 20 22 6d 61 69 6e 2e tests" #f "main.
19e0: 64 62 22 20 22 65 78 74 2d 74 65 73 74 73 22 20 db" "ext-tests"
19f0: 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 64 61 74 61 "/home/matt/data
1a00: 2f 6d 65 67 61 74 65 73 74 2f 62 69 6e 2f 2e 32 /megatest/bin/.2
1a10: 32 2e 30 34 2f 2e 2e 2f 6d 65 67 61 74 65 73 74 2.04/../megatest
1a20: 22 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ").;;.(define (t
1a30: 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 t:handler ttdat
1a40: 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d cmd run-id param
1a50: 73 20 61 74 74 65 6d 70 74 6e 75 6d 20 61 72 65 s attemptnum are
1a60: 61 2d 64 61 74 20 61 72 65 61 70 61 74 68 20 72 a-dat areapath r
1a70: 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 eadonly-mode dbf
1a80: 6e 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 6d name testsuite m
1a90: 74 65 78 65 29 0a 20 20 3b 3b 20 4e 4f 54 45 3a texe). ;; NOTE:
1aa0: 20 61 72 65 61 70 61 74 68 20 69 73 20 70 61 73 areapath is pas
1ab0: 73 65 64 20 69 6e 20 61 6e 64 20 69 6e 20 74 74 sed in and in tt
1ac0: 20 73 74 72 75 63 74 2e 20 57 65 27 6c 6c 20 75 struct. We'll u
1ad0: 73 65 20 70 61 73 73 65 64 20 69 6e 20 76 61 6c se passed in val
1ae0: 75 65 20 66 6f 72 20 6e 6f 77 2e 0a 20 20 28 6c ue for now.. (l
1af0: 65 74 2a 20 28 28 63 6f 6e 6e 20 28 74 74 3a 63 et* ((conn (tt:c
1b00: 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f lient-connect-to
1b10: 2d 73 65 72 76 65 72 20 74 74 64 61 74 20 64 62 -server ttdat db
1b20: 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 fname run-id tes
1b30: 74 73 75 69 74 65 29 29 29 20 3b 3b 20 28 68 61 tsuite))) ;; (ha
1b40: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
1b50: 61 75 6c 74 20 28 74 74 2d 63 6f 6e 6e 73 20 74 ault (tt-conns t
1b60: 74 64 61 74 29 20 64 62 66 6e 61 6d 65 20 23 66 tdat) dbfname #f
1b70: 29 29 29 0a 20 20 20 20 28 69 66 20 63 6f 6e 6e ))). (if conn
1b80: 0a 09 3b 3b 20 68 61 76 65 20 63 6f 6e 6e 65 63 ..;; have connec
1b90: 74 69 6f 6e 2c 20 63 61 6c 6c 20 74 68 65 20 73 tion, call the s
1ba0: 65 72 76 65 72 0a 09 28 6c 65 74 2a 20 28 28 72 erver..(let* ((r
1bb0: 65 73 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 es (tt:send-rece
1bc0: 69 76 65 20 74 74 64 61 74 20 63 6f 6e 6e 20 63 ive ttdat conn c
1bd0: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
1be0: 29 29 29 0a 09 20 20 3b 3b 20 72 65 73 20 69 73 ))).. ;; res is
1bf0: 20 28 73 74 61 74 75 73 20 65 72 72 6d 73 67 20 (status errmsg
1c00: 72 65 73 75 6c 74 20 6d 65 74 61 29 0a 20 20 20 result meta).
1c10: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
1c20: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
1c30: 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6e 6e 3a 22 og-port* "conn:"
1c40: 20 63 6f 6e 6e 20 22 20 72 65 73 3a 20 22 20 72 conn " res: " r
1c50: 65 73 29 0a 09 20 20 28 6d 61 74 63 68 20 72 65 es).. (match re
1c60: 73 0a 09 20 20 20 20 28 28 73 74 61 74 75 73 20 s.. ((status
1c70: 65 72 72 6d 73 67 20 72 65 73 75 6c 74 20 6d 65 errmsg result me
1c80: 74 61 29 0a 09 20 20 20 20 20 28 69 66 20 28 6c ta).. (if (l
1c90: 69 73 74 3f 20 6d 65 74 61 29 0a 09 09 20 28 6c ist? meta)... (l
1ca0: 65 74 2a 20 28 28 64 65 6c 61 79 2d 77 61 69 74 et* ((delay-wait
1cb0: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 64 65 6c (alist-ref 'del
1cc0: 61 79 2d 77 61 69 74 20 6d 65 74 61 29 29 29 0a ay-wait meta))).
1cd0: 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e .. (if (and (n
1ce0: 75 6d 62 65 72 3f 20 64 65 6c 61 79 2d 77 61 69 umber? delay-wai
1cf0: 74 29 0a 09 09 09 20 20 20 20 28 3e 20 64 65 6c t).... (> del
1d00: 61 79 2d 77 61 69 74 20 30 29 29 0a 09 09 20 20 ay-wait 0))...
1d10: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 (begin....
1d20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1d30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1d40: 2a 20 22 53 65 72 76 65 72 20 69 73 20 6c 6f 61 * "Server is loa
1d50: 64 65 64 2c 20 64 65 6c 61 79 69 6e 67 20 22 64 ded, delaying "d
1d60: 65 6c 61 79 2d 77 61 69 74 22 20 73 65 63 6f 6e elay-wait" secon
1d70: 64 73 22 29 0a 09 09 09 20 28 74 68 72 65 61 64 ds").... (thread
1d80: 2d 73 6c 65 65 70 21 20 64 65 6c 61 79 2d 77 61 -sleep! delay-wa
1d90: 69 74 29 29 29 29 29 0a 09 20 20 20 20 20 28 63 it))))).. (c
1da0: 61 73 65 20 73 74 61 74 75 73 0a 09 20 20 20 20 ase status..
1db0: 20 20 20 28 28 62 75 73 79 29 20 3b 3b 20 72 65 ((busy) ;; re
1dc0: 73 75 6c 74 20 77 69 6c 6c 20 62 65 20 68 6f 77 sult will be how
1dd0: 20 6c 6f 6e 67 20 74 68 65 20 73 65 72 76 65 72 long the server
1de0: 20 77 61 6e 74 73 20 79 6f 75 20 74 6f 20 64 65 wants you to de
1df0: 6c 61 79 0a 09 09 28 64 65 62 75 67 3a 70 72 69 lay...(debug:pri
1e00: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1e10: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
1e20: 3a 20 73 65 72 76 65 72 20 66 6f 72 20 22 64 62 : server for "db
1e30: 66 6e 61 6d 65 22 20 69 73 20 6f 76 65 72 6c 6f fname" is overlo
1e40: 61 64 65 64 2c 20 77 69 6c 6c 20 74 72 79 20 61 aded, will try a
1e50: 67 61 69 6e 20 69 6e 20 22 72 65 73 75 6c 74 22 gain in "result"
1e60: 20 73 65 63 6f 6e 64 73 2e 22 29 0a 09 09 28 74 seconds.")...(t
1e70: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 69 66 hread-sleep! (if
1e80: 20 28 6e 75 6d 62 65 72 3f 20 72 65 73 75 6c 74 (number? result
1e90: 29 20 72 65 73 75 6c 74 20 32 29 29 0a 09 09 28 ) result 2))...(
1ea0: 74 74 3a 68 61 6e 64 6c 65 72 20 20 74 74 64 61 tt:handler ttda
1eb0: 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 t cmd run-id par
1ec0: 61 6d 73 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 ams (+ attemptnu
1ed0: 6d 20 31 29 20 61 72 65 61 2d 64 61 74 20 61 72 m 1) area-dat ar
1ee0: 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d eapath readonly-
1ef0: 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 mode dbfname tes
1f00: 74 73 75 69 74 65 20 6d 74 65 78 65 29 29 0a 09 tsuite mtexe))..
1f10: 20 20 20 20 20 20 20 28 28 6c 6f 61 64 65 64 29 ((loaded)
1f20: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
1f30: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1f40: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 ort* "WARNING: s
1f50: 65 72 76 65 72 20 66 6f 72 20 22 64 62 66 6e 61 erver for "dbfna
1f60: 6d 65 22 20 69 73 20 6c 6f 61 64 65 64 2c 20 73 me" is loaded, s
1f70: 6c 6f 77 69 6e 67 20 71 75 65 72 69 65 73 2e 22 lowing queries."
1f80: 29 0a 09 09 28 74 74 3a 62 61 63 6b 6f 66 66 2d )...(tt:backoff-
1f90: 69 6e 63 72 20 28 74 74 2d 63 6f 6e 6e 2d 68 6f incr (tt-conn-ho
1fa0: 73 74 20 63 6f 6e 6e 29 28 74 74 2d 63 6f 6e 6e st conn)(tt-conn
1fb0: 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 09 72 -port conn))...r
1fc0: 65 73 75 6c 74 29 20 3b 3b 20 28 74 74 3a 68 61 esult) ;; (tt:ha
1fd0: 6e 64 6c 65 72 20 20 74 74 64 61 74 20 63 6d 64 ndler ttdat cmd
1fe0: 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 run-id params (
1ff0: 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 + attemptnum 1)
2000: 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 area-dat areapat
2010: 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 h readonly-mode
2020: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
2030: 65 20 6d 74 65 78 65 29 29 0a 09 20 20 20 20 20 e mtexe))..
2040: 20 20 28 65 6c 73 65 0a 09 09 72 65 73 75 6c 74 (else...result
2050: 29 29 29 0a 09 20 20 20 20 28 65 6c 73 65 20 3b ))).. (else ;
2060: 3b 20 64 69 64 20 6e 6f 74 20 72 65 63 65 69 76 ; did not receiv
2070: 65 20 70 72 6f 70 65 72 6c 79 20 66 6f 72 6d 61 e properly forma
2080: 74 65 64 20 72 65 73 75 6c 74 0a 09 20 20 20 20 ted result..
2090: 20 28 69 66 20 28 6e 6f 74 20 72 65 73 29 20 3b (if (not res) ;
20a0: 3b 20 74 74 3a 68 61 6e 64 6c 65 72 20 69 73 20 ; tt:handler is
20b0: 74 65 6c 6c 69 6e 67 20 75 73 20 74 68 61 74 20 telling us that
20c0: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 66 61 communication fa
20d0: 69 6c 65 64 0a 09 09 20 28 6c 65 74 2a 20 28 28 iled... (let* ((
20e0: 68 6f 73 74 20 20 20 20 28 74 74 2d 63 6f 6e 6e host (tt-conn
20f0: 2d 68 6f 73 74 20 63 6f 6e 6e 29 29 0a 09 09 09 -host conn))....
2100: 28 70 6f 72 74 20 20 20 20 28 74 74 2d 63 6f 6e (port (tt-con
2110: 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 09 n-port conn))...
2120: 09 3b 3b 20 28 64 62 66 6e 61 6d 65 20 28 74 74 .;; (dbfname (tt
2130: 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 -conn-port conn)
2140: 29 20 3b 3b 20 31 39 32 2e 31 36 38 2e 30 2e 31 ) ;; 192.168.0.1
2150: 32 37 3a 34 32 34 32 2d 37 32 36 39 32 34 3a 34 27:4242-726924:4
2160: 2e 64 62 0a 09 09 09 28 70 69 64 20 20 20 20 20 .db....(pid
2170: 28 74 74 2d 63 6f 6e 6e 2d 70 69 64 20 20 63 6f (tt-conn-pid co
2180: 6e 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 nn)).
2190: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
21a0: 72 76 69 6e 66 20 28 74 74 2d 63 6f 6e 6e 2d 73 rvinf (tt-conn-s
21b0: 65 72 76 69 6e 66 2d 66 69 6c 65 20 63 6f 6e 6e ervinf-file conn
21c0: 29 29 29 20 0a 09 09 09 3b 3b 28 73 65 72 76 69 ))) ....;;(servi
21d0: 6e 66 20 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 nf (tt-servinf-f
21e0: 69 6c 65 20 74 74 64 61 74 29 29 29 20 3b 3b 20 ile ttdat))) ;;
21f0: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f (conc areapath"/
2200: 2e 73 65 72 76 69 6e 66 6f 2f 22 68 6f 73 74 22 .servinfo/"host"
2210: 3a 22 70 6f 72 74 22 2d 22 70 69 64 22 3a 22 64 :"port"-"pid":"d
2220: 62 66 6e 61 6d 65 29 29 29 20 3b 3b 20 54 4f 44 bfname))) ;; TOD
2230: 4f 2c 20 75 73 65 20 28 73 65 72 76 65 72 3a 67 O, use (server:g
2240: 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 et-servinfo-dir
2250: 61 72 65 61 70 61 74 68 29 0a 09 09 20 20 20 28 areapath)... (
2260: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
2270: 28 74 74 2d 63 6f 6e 6e 73 20 74 74 64 61 74 29 (tt-conns ttdat)
2280: 20 64 62 66 6e 61 6d 65 20 23 66 29 0a 09 09 20 dbfname #f)...
2290: 20 20 28 69 66 20 28 61 6e 64 20 73 65 72 76 69 (if (and servi
22a0: 6e 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nf (file-exists?
22b0: 20 73 65 72 76 69 6e 66 29 29 0a 09 09 20 20 20 servinf))...
22c0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 28 (begin.... (
22d0: 69 66 20 28 3c 20 61 74 74 65 6d 70 74 6e 75 6d if (< attemptnum
22e0: 20 33 29 0a 09 09 09 20 20 20 20 20 28 62 65 67 3).... (beg
22f0: 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 74 68 in.... (th
2300: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 read-sleep! 0.25
2310: 29 0a 09 09 09 20 20 20 20 20 20 20 28 74 74 3a ).... (tt:
2320: 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d handler ttdat cm
2330: 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 d run-id params
2340: 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 (+ attemptnum 1)
2350: 20 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 area-dat areapa
2360: 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 th readonly-mode
2370: 20 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 dbfname testsui
2380: 74 65 20 6d 74 65 78 65 29 29 0a 09 09 09 20 20 te mtexe))....
2390: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 (begin....
23a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
23b0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
23c0: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 6e 6f 20 port* "INFO: no
23d0: 72 65 73 70 6f 6e 73 65 20 66 72 6f 6d 20 73 65 response from se
23e0: 72 76 65 72 20 22 68 6f 73 74 22 3a 22 70 6f 72 rver "host":"por
23f0: 74 22 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 29 t" for "dbfname)
2400: 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 .... (if (
2410: 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 and (file-exists
2420: 3f 20 73 65 72 76 69 6e 66 29 0a 09 09 09 09 09 ? servinf)......
2430: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
2440: 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d 6f 64 econds)(file-mod
2450: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 ification-time s
2460: 65 72 76 69 6e 66 29 29 20 36 30 29 29 0a 09 09 ervinf)) 60))...
2470: 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 .. (begin.....
2480: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2490: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
24a0: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 22 73 -port* "INFO: "s
24b0: 65 72 76 69 6e 66 22 20 66 69 6c 65 20 73 65 65 ervinf" file see
24c0: 6d 73 20 6f 6c 64 20 61 6e 64 20 6e 6f 20 70 69 ms old and no pi
24d0: 6e 67 20 72 65 73 70 6f 6e 73 65 2c 20 72 65 6d ng response, rem
24e0: 6f 76 69 6e 67 20 69 74 2e 22 29 0a 09 09 09 09 oving it.").....
24f0: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
2500: 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 65 78 eptions...... ex
2510: 6e 0a 09 09 09 09 20 20 20 20 20 20 20 23 66 0a n..... #f.
2520: 09 09 09 09 20 20 20 20 20 20 20 28 64 65 6c 65 .... (dele
2530: 74 65 2d 66 69 6c 65 2a 20 73 65 72 76 69 6e 66 te-file* servinf
2540: 29 29 0a 09 09 09 09 20 20 20 20 20 28 74 74 3a ))..... (tt:
2550: 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d handler ttdat cm
2560: 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 d run-id params
2570: 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 (+ attemptnum 1)
2580: 20 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 area-dat areapa
2590: 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 th readonly-mode
25a0: 20 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 dbfname testsui
25b0: 74 65 20 6d 74 65 78 65 29 29 0a 09 09 09 09 20 te mtexe)).....
25c0: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
25d0: 20 20 3b 3b 20 73 74 61 72 74 20 73 65 72 76 65 ;; start serve
25e0: 72 20 2d 20 61 64 64 72 65 73 73 65 64 20 69 6e r - addressed in
25f0: 20 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d client-connect-
2600: 74 6f 2d 73 65 72 76 65 72 0a 09 09 09 09 20 20 to-server.....
2610: 20 20 20 3b 3b 20 64 65 6c 61 79 20 20 20 20 20 ;; delay
2620: 20 20 20 2d 20 61 64 64 72 65 73 73 65 64 20 69 - addressed i
2630: 6e 20 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 n client-connect
2640: 2d 74 6f 2d 73 65 72 76 65 72 0a 09 09 09 09 20 -to-server.....
2650: 20 20 20 20 3b 3b 20 74 72 79 20 61 67 61 69 6e ;; try again
2660: 0a 09 09 09 09 20 20 20 20 20 28 74 68 72 65 61 ..... (threa
2670: 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 20 3b d-sleep! 0.25) ;
2680: 3b 20 64 75 6e 6e 6f 2c 20 49 20 74 68 69 6e 6b ; dunno, I think
2690: 20 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 62 this needs to b
26a0: 65 20 68 65 72 65 0a 09 09 09 09 20 20 20 20 20 e here.....
26b0: 28 74 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 (tt:handler ttda
26c0: 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 t cmd run-id par
26d0: 61 6d 73 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 ams (+ attemptnu
26e0: 6d 20 31 29 20 61 72 65 61 2d 64 61 74 20 61 72 m 1) area-dat ar
26f0: 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d eapath readonly-
2700: 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 mode dbfname tes
2710: 74 73 75 69 74 65 20 6d 74 65 78 65 29 29 0a 09 tsuite mtexe))..
2720: 09 09 09 20 20 20 29 29 29 29 0a 09 09 20 20 20 ... ))))...
2730: 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6e 6f (begin ;; no
2740: 20 73 65 72 76 65 72 20 66 69 6c 65 2c 20 64 65 server file, de
2750: 6c 61 79 20 61 6e 64 20 74 72 79 20 61 67 61 69 lay and try agai
2760: 6e 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 n.... (debug:pri
2770: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
2780: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 63 g-port* "INFO: c
2790: 6f 6e 6e 65 63 74 69 6f 6e 20 74 6f 20 73 65 72 onnection to ser
27a0: 76 65 72 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 ver "host":"port
27b0: 22 20 62 72 6f 6b 65 6e 20 66 6f 72 20 22 64 62 " broken for "db
27c0: 66 6e 61 6d 65 22 2c 20 62 75 74 20 64 6f 20 6e fname", but do n
27d0: 6f 74 20 73 65 65 20 73 65 72 76 69 6e 66 20 66 ot see servinf f
27e0: 69 6c 65 20 22 73 65 72 76 69 6e 66 29 0a 09 09 ile "servinf)...
27f0: 09 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 . (thread-sleep!
2800: 20 30 2e 35 29 0a 09 09 09 20 28 74 74 3a 68 61 0.5).... (tt:ha
2810: 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 ndler ttdat cmd
2820: 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 2b run-id params (+
2830: 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 61 attemptnum 1) a
2840: 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 68 rea-dat areapath
2850: 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 readonly-mode d
2860: 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 65 bfname testsuite
2870: 20 6d 74 65 78 65 29 29 29 29 0a 09 09 20 28 62 mtexe))))... (b
2880: 65 67 69 6e 20 3b 3b 20 74 68 69 73 20 63 61 73 egin ;; this cas
2890: 65 20 69 73 20 77 68 65 72 65 20 72 65 73 20 69 e is where res i
28a0: 73 20 6d 61 6c 66 6f 72 6d 65 64 2e 20 50 72 6f s malformed. Pro
28b0: 62 61 62 6c 79 20 73 68 6f 75 6c 64 20 61 62 6f bably should abo
28c0: 72 74 0a 09 09 20 20 20 28 61 73 73 65 72 74 20 rt... (assert
28d0: 23 66 20 22 46 41 54 41 4c 3a 20 74 74 3a 68 61 #f "FATAL: tt:ha
28e0: 6e 64 6c 65 72 20 72 65 63 65 69 76 65 64 20 62 ndler received b
28f0: 61 64 20 64 61 74 61 20 22 72 65 73 29 0a 09 09 ad data "res)...
2900: 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
2910: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
2920: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 67 g-port* "INFO: g
2930: 6f 74 20 63 6f 72 72 75 70 74 20 64 61 74 61 20 ot corrupt data
2940: 66 72 6f 6d 20 73 65 72 76 65 72 20 22 68 6f 73 from server "hos
2950: 74 22 3a 22 70 6f 72 74 22 2c 20 22 72 65 73 22 t":"port", "res"
2960: 2c 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 22 2c , for "dbfname",
2970: 20 77 69 6c 6c 20 74 72 79 20 61 67 61 69 6e 2e will try again.
2980: 22 29 0a 09 09 20 20 20 3b 3b 20 28 74 74 3a 68 ")... ;; (tt:h
2990: 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d 64 andler ttdat cmd
29a0: 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 run-id params (
29b0: 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 + attemptnum 1)
29c0: 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 area-dat areapat
29d0: 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 h readonly-mode
29e0: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
29f0: 65 20 6d 74 65 78 65 29 0a 09 09 20 20 20 29 29 e mtexe)... ))
2a00: 29 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 )))..(begin.. (
2a10: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
2a20: 20 3b 3b 20 6e 6f 20 63 6f 6e 6e 20 79 65 74 20 ;; no conn yet
2a30: 73 65 74 20 75 70 2c 20 67 69 76 65 20 69 74 20 set up, give it
2a40: 61 20 72 65 73 74 20 61 6e 64 20 74 72 79 20 61 a rest and try a
2a50: 67 61 69 6e 0a 09 20 20 28 74 74 3a 68 61 6e 64 gain.. (tt:hand
2a60: 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 75 ler ttdat cmd ru
2a70: 6e 2d 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 n-id params atte
2a80: 6d 70 74 6e 75 6d 20 61 72 65 61 2d 64 61 74 20 mptnum area-dat
2a90: 61 72 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c areapath readonl
2aa0: 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 y-mode dbfname t
2ab0: 65 73 74 73 75 69 74 65 20 6d 74 65 78 65 29 29 estsuite mtexe))
2ac0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 )))..(define (tt
2ad0: 3a 62 69 64 2d 66 6f 72 2d 73 65 72 76 65 72 73 :bid-for-servers
2ae0: 68 69 70 20 72 75 6e 2d 69 64 29 0a 20 20 23 66 hip run-id). #f
2af0: 29 0a 0a 3b 3b 20 67 65 74 73 20 73 65 72 76 65 )..;; gets serve
2b00: 72 20 69 6e 66 6f 20 61 6e 64 20 61 70 70 65 6e r info and appen
2b10: 64 73 20 70 61 74 68 20 74 6f 20 73 65 72 76 65 ds path to serve
2b20: 72 20 66 69 6c 65 0a 3b 3b 20 73 6f 72 74 73 20 r file.;; sorts
2b30: 62 79 20 61 67 65 2c 20 6f 6c 64 65 73 74 20 66 by age, oldest f
2b40: 69 72 73 74 0a 3b 3b 0a 3b 3b 20 72 65 74 75 72 irst.;;.;; retur
2b50: 6e 73 20 6c 69 73 74 20 6f 66 20 28 68 6f 73 74 ns list of (host
2b60: 20 70 6f 72 74 20 73 74 61 72 74 73 65 63 6f 6e port startsecon
2b70: 64 73 20 73 65 72 76 65 72 2d 69 64 20 73 65 72 ds server-id ser
2b80: 76 69 6e 66 6f 66 69 6c 65 29 0a 3b 3b 0a 28 64 vinfofile).;;.(d
2b90: 65 66 69 6e 65 20 28 74 74 3a 67 65 74 2d 73 65 efine (tt:get-se
2ba0: 72 76 65 72 2d 69 6e 66 6f 2d 73 6f 72 74 65 64 rver-info-sorted
2bb0: 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 0a ttdat dbfname).
2bc0: 20 20 28 6c 65 74 2a 20 28 28 61 72 65 61 70 61 (let* ((areapa
2bd0: 74 68 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 th (tt-areapath
2be0: 74 74 64 61 74 29 29 0a 09 20 28 73 66 69 6c 65 ttdat)).. (sfile
2bf0: 73 20 20 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 s (tt:find-ser
2c00: 76 65 72 20 61 72 65 61 70 61 74 68 20 64 62 66 ver areapath dbf
2c10: 6e 61 6d 65 29 29 0a 09 20 28 73 64 61 74 73 20 name)).. (sdats
2c20: 20 20 20 28 66 69 6c 74 65 72 20 63 61 72 20 28 (filter car (
2c30: 6d 61 70 20 74 74 3a 73 65 72 76 65 72 2d 67 65 map tt:server-ge
2c40: 74 2d 69 6e 66 6f 20 73 66 69 6c 65 73 29 29 29 t-info sfiles)))
2c50: 20 3b 3b 20 66 69 72 73 74 20 65 6c 65 6d 65 6e ;; first elemen
2c60: 74 20 69 73 20 23 66 20 69 66 20 74 68 65 20 66 t is #f if the f
2c70: 69 6c 65 20 64 69 73 61 70 70 65 61 72 65 64 20 ile disappeared
2c80: 77 68 69 6c 65 20 62 65 69 6e 67 20 72 65 61 64 while being read
2c90: 0a 09 20 28 73 6f 72 74 65 64 20 20 20 28 73 6f .. (sorted (so
2ca0: 72 74 20 73 64 61 74 73 20 28 6c 61 6d 62 64 61 rt sdats (lambda
2cb0: 20 28 61 20 62 29 0a 09 09 09 09 20 28 6c 65 74 (a b)..... (let
2cc0: 2a 20 28 28 73 74 61 72 74 61 20 28 6c 69 73 74 * ((starta (list
2cd0: 2d 72 65 66 20 61 20 32 29 29 0a 09 09 09 09 09 -ref a 2))......
2ce0: 28 73 74 61 72 74 62 20 28 6c 69 73 74 2d 72 65 (startb (list-re
2cf0: 66 20 62 20 32 29 29 29 0a 09 09 09 09 20 20 20 f b 2))).....
2d00: 28 69 66 20 28 65 71 3f 20 73 74 61 72 74 61 20 (if (eq? starta
2d10: 73 74 61 72 74 62 29 0a 09 09 09 09 20 20 20 20 startb).....
2d20: 20 20 20 28 73 74 72 69 6e 67 3e 3f 20 28 6c 69 (string>? (li
2d30: 73 74 2d 72 65 66 20 61 20 33 29 28 6c 69 73 74 st-ref a 3)(list
2d40: 2d 72 65 66 20 62 20 33 29 29 20 3b 3b 20 69 66 -ref b 3)) ;; if
2d50: 20 73 65 72 76 65 72 73 20 73 74 61 72 74 65 64 servers started
2d60: 20 61 74 20 73 61 6d 65 20 74 69 6d 65 20 6c 6f at same time lo
2d70: 6f 6b 20 61 74 20 73 65 72 76 65 72 2d 69 64 0a ok at server-id.
2d80: 09 09 09 09 20 20 20 20 20 20 20 28 3c 20 73 74 .... (< st
2d90: 61 72 74 61 20 73 74 61 72 74 62 29 29 29 29 29 arta startb)))))
2da0: 29 0a 09 20 28 63 6f 75 6e 74 20 20 20 20 30 29 ).. (count 0)
2db0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
2dc0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 65 (lambda (re
2dd0: 63 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 6f c). (if (o
2de0: 72 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 6f 72 r (> (length sor
2df0: 74 65 64 29 20 31 29 0a 09 20 20 20 20 20 20 20 ted) 1)..
2e00: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
2e10: 65 2d 70 72 69 6e 74 20 31 32 30 20 22 73 65 72 e-print 120 "ser
2e20: 76 65 72 20 69 6e 66 6f 20 73 6f 72 74 65 64 22 ver info sorted"
2e30: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
2e40: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
2e50: 6f 67 2d 70 6f 72 74 2a 20 22 53 45 52 56 45 52 og-port* "SERVER
2e60: 20 23 22 63 6f 75 6e 74 22 3a 20 22 28 73 74 72 #"count": "(str
2e70: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
2e80: 28 6d 61 70 20 63 6f 6e 63 20 73 6f 72 74 65 64 (map conc sorted
2e90: 29 20 22 2c 20 22 29 29 29 0a 20 20 20 20 20 20 ) ", "))).
2ea0: 20 28 73 65 74 21 20 63 6f 75 6e 74 20 28 2b 20 (set! count (+
2eb0: 63 6f 75 6e 74 20 31 29 29 29 0a 20 20 20 20 20 count 1))).
2ec0: 73 6f 72 74 65 64 29 0a 20 20 20 20 73 6f 72 74 sorted). sort
2ed0: 65 64 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e ed)). .(defin
2ee0: 65 20 28 74 74 3a 67 65 74 2d 63 75 72 72 65 6e e (tt:get-curren
2ef0: 74 2d 73 65 72 76 65 72 2d 69 6e 66 6f 20 74 74 t-server-info tt
2f00: 64 61 74 20 64 62 66 6e 61 6d 65 29 0a 20 20 28 dat dbfname). (
2f10: 61 73 73 65 72 74 20 28 74 74 2d 61 72 65 61 70 assert (tt-areap
2f20: 61 74 68 20 74 74 64 61 74 29 20 22 46 41 54 41 ath ttdat) "FATA
2f30: 4c 3a 20 61 72 65 61 70 61 74 68 20 6e 6f 74 20 L: areapath not
2f40: 73 65 74 20 69 6e 20 74 74 64 61 74 2e 22 29 0a set in ttdat.").
2f50: 20 20 3b 3b 0a 20 20 3b 3b 20 54 4f 44 4f 20 2d ;;. ;; TODO -
2f60: 20 72 65 70 6c 61 63 65 20 6d 6f 73 74 20 6f 66 replace most of
2f70: 20 62 65 6c 6f 77 20 77 69 74 68 20 74 74 3b 67 below with tt;g
2f80: 65 74 2d 73 65 72 76 65 72 2d 69 6e 66 6f 2d 73 et-server-info-s
2f90: 6f 72 74 65 64 0a 20 20 3b 3b 0a 20 20 28 6c 65 orted. ;;. (le
2fa0: 74 2a 20 28 28 61 72 65 61 70 61 74 68 20 28 74 t* ((areapath (t
2fb0: 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 61 74 t-areapath ttdat
2fc0: 29 29 0a 09 20 28 73 66 69 6c 65 73 20 20 20 28 )).. (sfiles (
2fd0: 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 72 20 61 tt:find-server a
2fe0: 72 65 61 70 61 74 68 20 64 62 66 6e 61 6d 65 29 reapath dbfname)
2ff0: 29 0a 09 20 28 73 64 61 74 73 20 20 20 20 28 66 ).. (sdats (f
3000: 69 6c 74 65 72 20 63 61 72 20 28 6d 61 70 20 74 ilter car (map t
3010: 74 3a 73 65 72 76 65 72 2d 67 65 74 2d 69 6e 66 t:server-get-inf
3020: 6f 20 73 66 69 6c 65 73 29 29 29 20 3b 3b 20 66 o sfiles))) ;; f
3030: 69 72 73 74 20 65 6c 65 6d 65 6e 74 20 69 73 20 irst element is
3040: 23 66 20 69 66 20 74 68 65 20 66 69 6c 65 20 64 #f if the file d
3050: 69 73 61 70 70 65 61 72 65 64 20 77 68 69 6c 65 isappeared while
3060: 20 62 65 69 6e 67 20 72 65 61 64 0a 09 20 28 73 being read.. (s
3070: 6f 72 74 65 64 20 20 20 28 73 6f 72 74 20 73 64 orted (sort sd
3080: 61 74 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 ats (lambda (a b
3090: 29 0a 09 09 09 09 20 28 3c 20 28 6c 69 73 74 2d )..... (< (list-
30a0: 72 65 66 20 61 20 32 29 28 6c 69 73 74 2d 72 65 ref a 2)(list-re
30b0: 66 20 62 20 32 29 29 29 29 29 29 0a 20 20 20 20 f b 2)))))).
30c0: 28 69 66 20 28 6e 75 6c 6c 3f 20 73 6f 72 74 65 (if (null? sorte
30d0: 64 29 0a 09 23 66 20 20 3b 3b 20 77 65 27 6c 6c d)..#f ;; we'll
30e0: 20 77 61 6e 74 20 74 6f 20 77 61 69 74 20 75 6e want to wait un
30f0: 74 69 6c 20 65 78 74 72 61 20 73 65 72 76 65 72 til extra server
3100: 73 20 68 61 76 65 20 65 78 69 74 65 64 0a 09 28 s have exited..(
3110: 63 61 72 20 73 6f 72 74 65 64 29 29 29 29 0a 0a car sorted))))..
3120: 28 64 65 66 69 6e 65 20 28 74 74 3a 73 65 6e 64 (define (tt:send
3130: 2d 72 65 63 65 69 76 65 20 74 74 64 61 74 20 63 -receive ttdat c
3140: 6f 6e 6e 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 onn cmd run-id p
3150: 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 arams). (let* (
3160: 28 68 6f 73 74 2d 70 6f 72 74 20 28 74 74 2d 63 (host-port (tt-c
3170: 6f 6e 6e 2d 68 6f 73 74 2d 70 6f 72 74 20 63 6f onn-host-port co
3180: 6e 6e 29 29 20 3b 3b 20 28 63 6f 6e 63 20 28 74 nn)) ;; (conc (t
3190: 74 2d 63 6f 6e 6e 2d 68 6f 73 74 20 63 6f 6e 6e t-conn-host conn
31a0: 29 22 3a 22 28 74 74 2d 63 6f 6e 6e 2d 70 6f 72 )":"(tt-conn-por
31b0: 74 20 63 6f 6e 6e 29 29 29 0a 09 20 28 68 6f 73 t conn))).. (hos
31c0: 74 20 20 20 20 20 20 28 74 74 2d 63 6f 6e 6e 2d t (tt-conn-
31d0: 68 6f 73 74 20 63 6f 6e 6e 29 29 0a 09 20 28 70 host conn)).. (p
31e0: 6f 72 74 20 20 20 20 20 20 28 74 74 2d 63 6f 6e ort (tt-con
31f0: 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 20 n-port conn))..
3200: 28 64 61 74 20 20 20 20 20 20 20 28 6c 69 73 74 (dat (list
3210: 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 cmd run-id para
3220: 6d 73 20 23 66 29 29 29 20 3b 3b 20 6e 6f 20 6d ms #f))) ;; no m
3230: 65 74 61 20 64 61 74 61 20 79 65 74 0a 20 20 20 eta data yet.
3240: 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (tt:send-receiv
3250: 65 2d 64 69 72 65 63 74 20 68 6f 73 74 20 70 6f e-direct host po
3260: 72 74 20 64 61 74 29 29 29 0a 0a 28 64 65 66 73 rt dat)))..(defs
3270: 74 72 75 63 74 20 74 74 3a 62 61 63 6b 6f 66 66 truct tt:backoff
3280: 0a 20 20 28 6c 61 73 74 2d 69 6f 65 72 72 20 28 . (last-ioerr (
3290: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
32a0: 29 0a 20 20 28 6c 61 73 74 2d 61 64 6a 2d 74 20 ). (last-adj-t
32b0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
32c0: 29 29 0a 20 20 28 77 61 69 74 2d 64 65 6c 61 79 )). (wait-delay
32d0: 20 30 2e 31 29 29 0a 0a 28 64 65 66 69 6e 65 20 0.1))..(define
32e0: 2a 74 74 3a 62 61 63 6b 6f 66 66 2d 73 6d 6f 6f *tt:backoff-smoo
32f0: 74 68 69 6e 67 2a 20 28 6d 61 6b 65 2d 68 61 73 thing* (make-has
3300: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 68 6f 73 h-table)) ;; hos
3310: 74 3a 70 6f 72 74 20 3d 3e 20 6c 61 73 74 61 63 t:port => lastac
3320: 63 65 73 73 20 62 61 63 6b 6f 66 66 64 65 6c 61 cess backoffdela
3330: 79 20 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 y )..(define (tt
3340: 3a 62 61 63 6b 6f 66 66 2d 69 6e 63 72 20 68 6f :backoff-incr ho
3350: 73 74 20 70 6f 72 74 29 20 3b 3b 20 63 61 6c 6c st port) ;; call
3360: 20 69 66 20 74 63 70 20 66 61 69 6c 73 20 69 2f if tcp fails i/
3370: 6f 20 6e 65 74 0a 20 20 28 6c 65 74 2a 20 28 28 o net. (let* ((
3380: 68 6f 73 74 2d 70 6f 72 74 20 28 63 6f 6e 63 20 host-port (conc
3390: 68 6f 73 74 22 3a 22 70 6f 72 74 29 29 0a 09 20 host":"port))..
33a0: 28 62 6b 6f 66 66 20 20 20 20 20 28 68 61 73 68 (bkoff (hash
33b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
33c0: 6c 74 20 2a 74 74 3a 62 61 63 6b 6f 66 66 2d 73 lt *tt:backoff-s
33d0: 6d 6f 6f 74 68 69 6e 67 2a 20 68 6f 73 74 2d 70 moothing* host-p
33e0: 6f 72 74 20 23 66 29 29 29 0a 20 20 20 20 28 69 ort #f))). (i
33f0: 66 20 62 6b 6f 66 66 0a 09 28 62 65 67 69 6e 0a f bkoff..(begin.
3400: 09 20 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d 6c . (tt:backoff-l
3410: 61 73 74 2d 69 6f 65 72 72 2d 73 65 74 21 20 62 ast-ioerr-set! b
3420: 6b 6f 66 66 20 28 63 75 72 72 65 6e 74 2d 73 65 koff (current-se
3430: 63 6f 6e 64 73 29 29 0a 09 20 20 28 74 74 3a 62 conds)).. (tt:b
3440: 61 63 6b 6f 66 66 2d 77 61 69 74 2d 64 65 6c 61 ackoff-wait-dela
3450: 79 2d 73 65 74 21 20 62 6b 6f 66 66 20 28 2b 20 y-set! bkoff (+
3460: 28 74 74 3a 62 61 63 6b 6f 66 66 2d 77 61 69 74 (tt:backoff-wait
3470: 2d 64 65 6c 61 79 20 62 6b 6f 66 66 29 20 30 2e -delay bkoff) 0.
3480: 31 29 29 29 0a 09 28 68 61 73 68 2d 74 61 62 6c 1)))..(hash-tabl
3490: 65 2d 73 65 74 21 20 2a 74 74 3a 62 61 63 6b 6f e-set! *tt:backo
34a0: 66 66 2d 73 6d 6f 6f 74 68 69 6e 67 2a 20 68 6f ff-smoothing* ho
34b0: 73 74 2d 70 6f 72 74 20 28 6d 61 6b 65 2d 74 74 st-port (make-tt
34c0: 3a 62 61 63 6b 6f 66 66 29 29 29 29 29 0a 0a 28 :backoff)))))..(
34d0: 64 65 66 69 6e 65 20 28 74 74 3a 62 61 63 6b 6f define (tt:backo
34e0: 66 66 2d 64 65 63 72 2d 61 6e 64 2d 77 61 69 74 ff-decr-and-wait
34f0: 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 28 6c host port). (l
3500: 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 et* ((host-port
3510: 28 63 6f 6e 63 20 68 6f 73 74 22 3a 22 70 6f 72 (conc host":"por
3520: 74 29 29 0a 09 20 28 62 6b 6f 66 66 20 20 20 20 t)).. (bkoff
3530: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3540: 2f 64 65 66 61 75 6c 74 20 2a 74 74 3a 62 61 63 /default *tt:bac
3550: 6b 6f 66 66 2d 73 6d 6f 6f 74 68 69 6e 67 2a 20 koff-smoothing*
3560: 68 6f 73 74 2d 70 6f 72 74 20 23 66 29 29 29 0a host-port #f))).
3570: 20 20 20 20 28 69 66 20 62 6b 6f 66 66 0a 09 28 (if bkoff..(
3580: 6c 65 74 2a 20 28 28 77 61 69 74 2d 64 65 6c 61 let* ((wait-dela
3590: 79 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d 77 61 y (tt:backoff-wa
35a0: 69 74 2d 64 65 6c 61 79 20 62 6b 6f 66 66 29 29 it-delay bkoff))
35b0: 0a 09 20 20 20 20 20 20 20 28 6c 61 73 74 2d 69 .. (last-i
35c0: 6f 65 72 72 20 28 74 74 3a 62 61 63 6b 6f 66 66 oerr (tt:backoff
35d0: 2d 6c 61 73 74 2d 69 6f 65 72 72 20 62 6b 6f 66 -last-ioerr bkof
35e0: 66 29 29 0a 09 20 20 20 20 20 20 20 28 6c 61 73 f)).. (las
35f0: 74 2d 61 64 6a 2d 74 20 28 74 74 3a 62 61 63 6b t-adj-t (tt:back
3600: 6f 66 66 2d 6c 61 73 74 2d 61 64 6a 2d 74 20 62 off-last-adj-t b
3610: 6b 6f 66 66 29 29 0a 09 20 20 20 20 20 20 20 28 koff)).. (
3620: 64 65 6c 74 61 20 20 20 20 20 20 28 2d 20 28 63 delta (- (c
3630: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
3640: 6c 61 73 74 2d 61 64 6a 2d 74 29 29 0a 09 20 20 last-adj-t))..
3650: 20 20 20 20 20 28 61 64 6a 20 20 20 20 20 20 20 (adj
3660: 20 28 2a 20 64 65 6c 74 61 20 30 2e 30 30 31 29 (* delta 0.001)
3670: 29 20 3b 3b 20 69 74 20 74 61 6b 65 73 20 31 30 ) ;; it takes 10
3680: 30 20 73 65 63 6f 6e 64 73 20 74 6f 20 72 65 63 0 seconds to rec
3690: 6f 76 65 72 20 66 72 6f 6d 20 68 69 74 74 69 6e over from hittin
36a0: 67 20 61 6e 20 69 6f 20 65 72 72 0a 09 20 20 20 g an io err..
36b0: 20 20 20 20 28 6e 65 77 2d 77 61 69 74 20 20 20 (new-wait
36c0: 28 69 66 20 28 3e 20 77 61 69 74 2d 64 65 6c 61 (if (> wait-dela
36d0: 79 20 30 29 0a 09 09 09 20 20 20 20 20 20 20 28 y 0).... (
36e0: 69 66 20 28 3e 20 61 64 6a 20 77 61 69 74 2d 64 if (> adj wait-d
36f0: 65 6c 61 79 29 0a 09 09 09 09 20 20 20 30 0a 09 elay)..... 0..
3700: 09 09 09 20 20 20 28 2d 20 77 61 69 74 2d 64 65 ... (- wait-de
3710: 6c 61 79 20 61 64 6a 29 29 0a 09 09 09 20 20 20 lay adj))....
3720: 20 20 20 20 30 29 29 29 0a 09 20 20 28 69 66 20 0))).. (if
3730: 28 3e 20 6e 65 77 2d 77 61 69 74 20 30 29 0a 09 (> new-wait 0)..
3740: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
3750: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e if (common:low-n
3760: 6f 69 73 65 2d 70 72 69 6e 74 20 31 30 20 22 64 oise-print 10 "d
3770: 65 6c 61 79 20 77 61 69 74 20 6d 65 73 73 61 67 elay wait messag
3780: 65 22 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 e")... (debug
3790: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
37a0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
37b0: 20 22 53 65 72 76 65 72 20 6c 6f 61 64 65 64 2c "Server loaded,
37c0: 20 44 65 6c 61 79 57 61 69 74 3a 20 22 6e 65 77 DelayWait: "new
37d0: 2d 77 61 69 74 29 29 0a 09 09 28 74 74 3a 62 61 -wait))...(tt:ba
37e0: 63 6b 6f 66 66 2d 77 61 69 74 2d 64 65 6c 61 79 ckoff-wait-delay
37f0: 2d 73 65 74 21 20 62 6b 6f 66 66 20 6e 65 77 2d -set! bkoff new-
3800: 77 61 69 74 29 0a 09 09 28 74 74 3a 62 61 63 6b wait)...(tt:back
3810: 6f 66 66 2d 6c 61 73 74 2d 61 64 6a 2d 74 2d 73 off-last-adj-t-s
3820: 65 74 21 20 62 6b 6f 66 66 20 28 63 75 72 72 65 et! bkoff (curre
3830: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 28 nt-seconds))...(
3840: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 6e 65 thread-sleep! ne
3850: 77 2d 77 61 69 74 29 29 0a 09 20 20 20 20 20 20 w-wait))..
3860: 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 (hash-table-dele
3870: 74 65 21 20 2a 74 74 3a 62 61 63 6b 6f 66 66 2d te! *tt:backoff-
3880: 73 6d 6f 6f 74 68 69 6e 67 2a 20 68 6f 73 74 2d smoothing* host-
3890: 70 6f 72 74 29 29 29 29 29 29 0a 0a 28 64 65 66 port))))))..(def
38a0: 69 6e 65 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 ine (tt:send-rec
38b0: 65 69 76 65 2d 64 69 72 65 63 74 20 68 6f 73 74 eive-direct host
38c0: 20 70 6f 72 74 20 64 61 74 20 23 21 6b 65 79 20 port dat #!key
38d0: 28 70 69 6e 67 2d 6d 6f 64 65 20 23 66 29 28 74 (ping-mode #f)(t
38e0: 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e 67 20 32 ries-remaining 2
38f0: 35 29 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 5)). (assert (n
3900: 75 6d 62 65 72 3f 20 70 6f 72 74 29 20 22 46 41 umber? port) "FA
3910: 54 41 4c 3a 20 74 74 3a 73 65 6e 64 2d 72 65 63 TAL: tt:send-rec
3920: 65 69 76 65 2d 64 69 72 65 63 74 20 63 61 6c 6c eive-direct call
3930: 65 64 20 77 69 74 68 20 70 6f 72 74 20 6e 6f 74 ed with port not
3940: 20 61 20 6e 75 6d 62 65 72 20 22 70 6f 72 74 29 a number "port)
3950: 0a 20 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d 64 . (tt:backoff-d
3960: 65 63 72 2d 61 6e 64 2d 77 61 69 74 20 68 6f 73 ecr-and-wait hos
3970: 74 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 t port). (let*
3980: 28 28 72 65 74 72 79 20 20 20 20 20 20 20 20 20 ((retry
3990: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
39a0: 20 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 (tt:send-recei
39b0: 76 65 2d 64 69 72 65 63 74 20 68 6f 73 74 20 70 ve-direct host p
39c0: 6f 72 74 20 64 61 74 20 74 72 69 65 73 2d 72 65 ort dat tries-re
39d0: 6d 61 69 6e 69 6e 67 3a 20 28 2d 20 74 72 69 65 maining: (- trie
39e0: 73 2d 72 65 6d 61 69 6e 69 6e 67 20 31 29 29 29 s-remaining 1)))
39f0: 29 0a 09 20 28 66 75 6c 6c 2d 65 72 72 2d 70 72 ).. (full-err-pr
3a00: 69 6e 74 20 28 6c 61 6d 62 64 61 20 28 65 78 6e int (lambda (exn
3a10: 20 6d 73 67 29 0a 09 09 09 20 20 20 28 69 66 20 msg).... (if
3a20: 28 63 6f 6e 64 69 74 69 6f 6e 3f 20 65 78 6e 29 (condition? exn)
3a30: 0a 09 09 09 20 20 20 20 20 20 20 28 62 65 67 69 .... (begi
3a40: 6e 0a 09 09 09 09 20 28 70 70 20 28 63 6f 6e 64 n..... (pp (cond
3a50: 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 ition->list exn)
3a60: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3a70: 72 74 2a 29 0a 09 09 09 09 20 28 70 70 20 64 61 rt*)..... (pp da
3a80: 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 t *default-log-p
3a90: 6f 72 74 2a 29 0a 09 09 09 09 20 28 64 65 62 75 ort*)..... (debu
3aa0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3ab0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 6d 73 67 lt-log-port* msg
3ac0: 0a 09 09 09 09 09 20 20 20 20 20 20 22 2c 20 65 ...... ", e
3ad0: 72 72 6f 72 3a 20 22 20 20 20 20 20 28 28 63 6f rror: " ((co
3ae0: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
3af0: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
3b00: 6d 65 73 73 61 67 65 29 20 20 20 65 78 6e 29 0a message) exn).
3b10: 09 09 09 09 09 20 20 20 20 20 20 22 2c 20 61 72 ..... ", ar
3b20: 67 75 6d 65 6e 74 73 3a 20 22 20 28 28 63 6f 6e guments: " ((con
3b30: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
3b40: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 61 accessor 'exn 'a
3b50: 72 67 75 6d 65 6e 74 73 29 20 65 78 6e 29 0a 09 rguments) exn)..
3b60: 09 09 09 09 20 20 20 20 20 20 22 2c 20 6c 6f 63 .... ", loc
3b70: 61 74 69 6f 6e 3a 20 22 20 20 28 28 63 6f 6e 64 ation: " ((cond
3b80: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
3b90: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6c 6f ccessor 'exn 'lo
3ba0: 63 61 74 69 6f 6e 29 20 20 65 78 6e 29 0a 09 09 cation) exn)...
3bb0: 09 09 09 20 20 20 20 20 20 29 29 0a 09 09 09 20 ... ))....
3bc0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3bd0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
3be0: 67 2d 70 6f 72 74 2a 20 6d 73 67 20 22 28 6e 6f g-port* msg "(no
3bf0: 74 65 3a 20 65 78 6e 3d 22 65 78 6e 22 2c 20 69 te: exn="exn", i
3c00: 73 20 6e 6f 74 20 61 20 63 6f 6e 64 69 74 69 6f s not a conditio
3c10: 6e 20 6f 62 6a 65 63 74 2e 22 29 29 29 29 29 0a n object."))))).
3c20: 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 (condition-c
3c30: 61 73 65 0a 20 20 20 20 20 28 6c 65 74 2d 76 61 ase. (let-va
3c40: 6c 75 65 73 20 28 28 28 69 6e 70 20 6f 75 70 29 lues (((inp oup)
3c50: 28 74 63 70 2d 63 6f 6e 6e 65 63 74 20 68 6f 73 (tcp-connect hos
3c60: 74 20 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 t port))).
3c70: 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 66 20 (let ((res (if
3c80: 28 61 6e 64 20 69 6e 70 20 6f 75 70 29 0a 09 09 (and inp oup)...
3c90: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
3ca0: 28 73 65 72 69 61 6c 69 7a 65 20 64 61 74 20 6f (serialize dat o
3cb0: 75 70 29 0a 09 09 09 28 63 6c 6f 73 65 2d 6f 75 up)....(close-ou
3cc0: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 tput-port oup)..
3cd0: 09 09 28 64 65 73 65 72 69 61 6c 69 7a 65 20 69 ..(deserialize i
3ce0: 6e 70 29 29 0a 09 09 20 20 20 20 20 20 29 29 29 np))... )))
3cf0: 0a 09 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d .. (close-input-
3d00: 70 6f 72 74 20 69 6e 70 29 0a 09 20 28 6d 61 74 port inp).. (mat
3d10: 63 68 20 72 65 73 0a 09 20 20 20 28 28 72 65 73 ch res.. ((res
3d20: 75 6c 74 20 65 78 6e 2d 72 65 73 75 6c 74 20 73 ult exn-result s
3d30: 74 64 6f 75 74 2d 72 65 73 75 6c 74 29 0a 09 20 tdout-result)..
3d40: 20 20 20 28 69 66 20 65 78 6e 2d 72 65 73 75 6c (if exn-resul
3d50: 74 0a 09 09 28 66 75 6c 6c 2d 65 72 72 2d 70 72 t...(full-err-pr
3d60: 69 6e 74 20 65 78 6e 2d 72 65 73 75 6c 74 20 22 int exn-result "
3d70: 45 52 52 4f 52 3a 20 53 65 72 76 65 72 20 73 69 ERROR: Server si
3d80: 64 65 20 65 78 63 65 70 74 69 6f 6e 20 64 65 74 de exception det
3d90: 65 63 74 65 64 22 29 29 0a 09 20 20 20 20 28 69 ected")).. (i
3da0: 66 20 73 74 64 6f 75 74 2d 72 65 73 75 6c 74 0a f stdout-result.
3db0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
3dc0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3dd0: 72 74 2a 20 22 45 52 52 4f 52 3a 20 4f 75 74 70 rt* "ERROR: Outp
3de0: 75 74 20 64 65 74 65 63 74 65 64 20 6f 6e 20 73 ut detected on s
3df0: 74 64 6f 75 74 20 6f 6e 20 73 65 72 76 65 72 20 tdout on server
3e00: 73 69 64 65 20 65 78 65 63 75 74 69 6f 6e 20 3d side execution =
3e10: 3e 20 22 73 74 64 6f 75 74 2d 72 65 73 75 6c 74 > "stdout-result
3e20: 29 29 0a 09 20 20 20 20 72 65 73 75 6c 74 29 0a )).. result).
3e30: 09 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 28 . (else.. (
3e40: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3e50: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3e60: 20 22 45 52 52 4f 52 3a 20 73 65 72 76 65 72 20 "ERROR: server
3e70: 72 65 74 75 72 6e 65 64 20 6e 6f 6e 2d 73 74 61 returned non-sta
3e80: 6e 64 61 72 64 20 6f 75 74 70 75 74 3a 20 22 72 ndard output: "r
3e90: 65 73 29 0a 09 20 20 20 20 23 66 29 29 29 29 0a es).. #f)))).
3ea0: 20 20 20 20 20 28 65 78 6e 20 28 69 6f 2d 65 72 (exn (io-er
3eb0: 72 6f 72 29 0a 09 20 20 28 66 75 6c 6c 2d 65 72 ror).. (full-er
3ec0: 72 2d 70 72 69 6e 74 20 65 78 6e 20 20 22 45 52 r-print exn "ER
3ed0: 52 4f 52 3a 20 69 2f 6f 20 65 72 72 6f 72 22 29 ROR: i/o error")
3ee0: 0a 09 20 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d .. (tt:backoff-
3ef0: 69 6e 63 72 20 68 6f 73 74 20 70 6f 72 74 29 0a incr host port).
3f00: 09 20 20 23 66 29 0a 20 20 20 20 20 28 65 78 6e . #f). (exn
3f10: 20 28 69 2f 6f 20 6e 65 74 29 0a 09 20 20 28 69 (i/o net).. (i
3f20: 66 20 70 69 6e 67 2d 6d 6f 64 65 0a 09 20 20 20 f ping-mode..
3f30: 20 20 20 23 66 0a 09 20 20 20 20 20 20 28 63 6f #f.. (co
3f40: 6e 64 0a 09 20 20 20 20 20 20 20 28 28 3e 20 20 nd.. ((>
3f50: 74 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e 67 20 tries-remaining
3f60: 34 29 20 3b 3b 20 73 65 72 76 65 72 20 6c 69 6b 4) ;; server lik
3f70: 65 6c 79 20 64 65 66 75 6e 63 74 0a 09 09 28 74 ely defunct...(t
3f80: 74 3a 62 61 63 6b 6f 66 66 2d 69 6e 63 72 20 68 t:backoff-incr h
3f90: 6f 73 74 20 70 6f 72 74 29 0a 09 09 23 66 29 0a ost port)...#f).
3fa0: 09 20 20 20 20 20 20 20 28 28 3e 3d 20 74 72 69 . ((>= tri
3fb0: 65 73 2d 72 65 6d 61 69 6e 69 6e 67 20 30 29 0a es-remaining 0).
3fc0: 09 09 28 6c 65 74 2a 20 28 28 62 61 63 6b 6f 66 ..(let* ((backof
3fd0: 66 2d 64 65 6c 61 79 20 28 6d 61 78 20 28 2a 20 f-delay (max (*
3fe0: 28 2d 20 32 36 20 74 72 69 65 73 2d 72 65 6d 61 (- 26 tries-rema
3ff0: 69 6e 69 6e 67 29 20 30 2e 31 29 20 31 2e 30 29 ining) 0.1) 1.0)
4000: 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 ))... (debug:pr
4010: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
4020: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
4030: 47 3a 20 54 43 50 20 6f 76 65 72 6c 6f 61 64 2c G: TCP overload,
4040: 20 74 72 79 69 6e 67 20 61 67 61 69 6e 20 69 6e trying again in
4050: 20 22 62 61 63 6b 6f 66 66 2d 64 65 6c 61 79 22 "backoff-delay"
4060: 73 2e 22 29 0a 09 09 20 20 28 74 68 72 65 61 64 s.")... (thread
4070: 2d 73 6c 65 65 70 21 20 62 61 63 6b 6f 66 66 2d -sleep! backoff-
4080: 64 65 6c 61 79 29 0a 09 09 20 20 28 74 74 3a 62 delay)... (tt:b
4090: 61 63 6b 6f 66 66 2d 69 6e 63 72 20 68 6f 73 74 ackoff-incr host
40a0: 20 70 6f 72 74 29 0a 09 09 20 20 28 72 65 74 72 port)... (retr
40b0: 79 29 29 0a 09 09 28 61 73 73 65 72 74 20 23 66 y))...(assert #f
40c0: 20 22 46 41 54 41 4c 3a 20 54 6f 6f 20 6d 61 6e "FATAL: Too man
40d0: 79 20 72 65 74 72 69 65 73 20 69 6e 20 74 74 3a y retries in tt:
40e0: 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 64 69 72 send-receive-dir
40f0: 65 63 74 22 29 29 0a 09 20 20 20 20 20 20 20 28 ect")).. (
4100: 65 6c 73 65 20 23 66 29 29 29 29 0a 20 20 20 20 else #f)))).
4110: 20 28 65 78 6e 20 28 29 0a 09 20 20 28 66 75 6c (exn ().. (ful
4120: 6c 2d 65 72 72 2d 70 72 69 6e 74 20 65 78 6e 20 l-err-print exn
4130: 22 55 6e 68 61 6e 64 6c 65 64 20 65 78 63 65 70 "Unhandled excep
4140: 74 69 6f 6e 20 66 72 6f 6d 20 63 6c 69 65 6e 74 tion from client
4150: 20 73 69 64 65 2e 22 29 0a 09 20 20 23 66 29 29 side.").. #f))
4160: 29 29 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ))...;;=========
4170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
41a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
41b0: 20 73 65 72 76 65 72 0a 3b 3b 3d 3d 3d 3d 3d 3d server.;;======
41c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
41d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
41e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
41f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4200: 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 73 79 ..(define (tt:sy
4210: 6e 63 2d 64 62 73 20 74 74 64 61 74 29 0a 20 20 nc-dbs ttdat).
4220: 23 66 29 0a 0a 3b 3b 20 73 74 61 72 74 20 74 68 #f)..;; start th
4230: 65 20 6c 69 73 74 65 6e 65 72 20 61 6e 64 20 73 e listener and s
4240: 74 61 72 74 20 72 65 73 70 6f 6e 64 69 6e 67 20 tart responding
4250: 74 6f 20 72 65 71 75 65 73 74 73 0a 3b 3b 0a 3b to requests.;;.;
4260: 3b 20 4e 4f 54 45 3a 20 6f 72 67 61 6e 69 73 65 ; NOTE: organise
4270: 20 62 79 20 64 62 66 6e 61 6d 65 2c 20 6e 6f 74 by dbfname, not
4280: 20 72 75 6e 2d 69 64 20 73 6f 20 77 65 20 64 6f run-id so we do
4290: 6e 27 74 20 6e 65 65 64 0a 3b 3b 20 20 20 20 20 n't need.;;
42a0: 20 20 74 6f 20 70 75 6c 6c 20 69 6e 20 6d 6f 72 to pull in mor
42b0: 65 20 6d 6f 64 75 6c 65 73 0a 3b 3b 0a 3b 3b 20 e modules.;;.;;
42c0: 54 68 69 73 20 69 73 20 74 68 65 20 72 6f 75 74 This is the rout
42d0: 69 6e 65 20 63 61 6c 6c 65 64 20 69 6e 20 6d 65 ine called in me
42e0: 67 61 74 65 73 74 2e 73 63 6d 20 74 6f 20 73 74 gatest.scm to st
42f0: 61 72 74 20 61 20 73 65 72 76 65 72 0a 3b 3b 0a art a server.;;.
4300: 3b 3b 20 53 65 72 76 65 72 20 76 69 61 62 69 6c ;; Server viabil
4310: 69 74 79 20 69 73 20 63 68 65 63 6b 65 64 20 69 ity is checked i
4320: 6e 20 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 2e 20 n keep-running.
4330: 42 6c 69 6e 64 6c 79 20 73 74 61 72 74 20 61 6e Blindly start an
4340: 64 20 72 75 6e 20 68 65 72 65 2e 0a 3b 3b 0a 28 d run here..;;.(
4350: 64 65 66 69 6e 65 20 28 74 74 3a 73 74 61 72 74 define (tt:start
4360: 2d 73 65 72 76 65 72 20 61 72 65 61 70 61 74 68 -server areapath
4370: 20 72 75 6e 2d 69 64 20 64 62 66 6e 61 6d 65 2d run-id dbfname-
4380: 69 6e 20 68 61 6e 64 6c 65 72 20 6b 65 79 73 29 in handler keys)
4390: 0a 20 20 28 61 73 73 65 72 74 20 61 72 65 61 70 . (assert areap
43a0: 61 74 68 20 22 46 41 54 41 4c 3a 20 61 72 65 61 ath "FATAL: area
43b0: 70 61 74 68 20 6e 6f 74 20 70 72 6f 76 69 64 65 path not provide
43c0: 64 20 66 6f 72 20 74 74 3a 73 74 61 72 74 2d 73 d for tt:start-s
43d0: 65 72 76 65 72 22 29 0a 20 20 3b 3b 20 69 73 20 erver"). ;; is
43e0: 74 68 65 72 65 20 61 6c 72 65 61 64 79 20 61 20 there already a
43f0: 73 65 72 76 65 72 20 66 6f 72 20 74 68 69 73 20 server for this
4400: 64 62 66 69 6c 65 3f 20 54 68 65 6e 20 65 78 69 dbfile? Then exi
4410: 74 2e 0a 20 20 28 6c 65 74 2a 20 28 28 74 74 64 t.. (let* ((ttd
4420: 61 74 20 20 20 28 6d 61 6b 65 2d 74 74 20 61 72 at (make-tt ar
4430: 65 61 70 61 74 68 3a 20 61 72 65 61 70 61 74 68 eapath: areapath
4440: 29 29 0a 09 20 28 64 62 66 6e 61 6d 65 20 28 6f )).. (dbfname (o
4450: 72 20 64 62 66 6e 61 6d 65 2d 69 6e 20 28 64 62 r dbfname-in (db
4460: 6d 6f 64 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 6e mod:run-id->dbfn
4470: 61 6d 65 20 72 75 6e 2d 69 64 29 29 29 0a 09 20 ame run-id)))..
4480: 28 73 65 72 76 65 72 73 20 28 74 74 3a 66 69 6e (servers (tt:fin
4490: 64 2d 73 65 72 76 65 72 20 61 72 65 61 70 61 74 d-server areapat
44a0: 68 20 64 62 66 6e 61 6d 65 29 29 29 20 3b 3b 20 h dbfname))) ;;
44b0: 73 68 6f 75 6c 64 20 75 73 65 20 74 74 3a 67 65 should use tt:ge
44c0: 74 2d 63 75 72 72 65 6e 74 2d 73 65 72 76 65 72 t-current-server
44d0: 2d 69 6e 66 6f 20 69 6e 73 74 65 61 64 0a 20 20 -info instead.
44e0: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
44f0: 20 73 65 72 76 65 72 73 29 20 34 29 0a 09 28 62 servers) 4)..(b
4500: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
4510: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
4520: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
4530: 20 66 6f 75 6e 64 20 73 65 72 76 65 72 28 73 29 found server(s)
4540: 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 already running
4550: 20 66 6f 72 20 64 62 20 22 64 62 66 6e 61 6d 65 for db "dbfname
4560: 22 2c 20 22 28 73 74 72 69 6e 67 2d 69 6e 74 65 ", "(string-inte
4570: 72 73 70 65 72 73 65 20 73 65 72 76 65 72 73 20 rsperse servers
4580: 22 2c 22 29 22 20 45 78 69 74 69 6e 67 2e 22 29 ",")" Exiting.")
4590: 0a 09 20 20 28 65 78 69 74 29 29 0a 09 28 6c 65 .. (exit))..(le
45a0: 74 2a 20 28 28 64 62 73 74 72 75 63 74 20 20 20 t* ((dbstruct
45b0: 28 64 62 6d 6f 64 3a 6f 70 65 6e 2d 64 62 6d 6f (dbmod:open-dbmo
45c0: 64 64 62 20 61 72 65 61 70 61 74 68 20 72 75 6e ddb areapath run
45d0: 2d 69 64 20 64 62 66 6e 61 6d 65 20 28 64 62 66 -id dbfname (dbf
45e0: 69 6c 65 3a 64 62 2d 69 6e 69 74 2d 70 72 6f 63 ile:db-init-proc
45f0: 29 20 6b 65 79 73 29 29 29 0a 09 20 20 28 74 74 ) keys))).. (tt
4600: 2d 68 61 6e 64 6c 65 72 2d 73 65 74 21 20 74 74 -handler-set! tt
4610: 64 61 74 20 28 68 61 6e 64 6c 65 72 20 64 62 73 dat (handler dbs
4620: 74 72 75 63 74 29 29 0a 09 20 20 28 6c 65 74 2a truct)).. (let*
4630: 20 28 28 74 63 70 2d 74 68 72 65 61 64 20 28 6d ((tcp-thread (m
4640: 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 20 20 ake-thread....
4650: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
4660: 09 09 09 28 74 74 3a 73 74 61 72 74 2d 74 63 70 ...(tt:start-tcp
4670: 2d 73 65 72 76 65 72 20 74 74 64 61 74 29 29 20 -server ttdat))
4680: 3b 3b 20 73 74 61 72 74 20 74 68 65 20 74 63 70 ;; start the tcp
4690: 2d 73 65 72 76 65 72 20 77 68 69 63 68 20 61 70 -server which ap
46a0: 70 6c 69 65 73 20 68 61 6e 64 6c 65 72 20 74 6f plies handler to
46b0: 20 69 6e 63 6f 6d 69 6e 67 20 64 61 74 61 0a 09 incoming data..
46c0: 09 09 20 20 20 20 20 20 22 74 63 70 2d 73 65 72 .. "tcp-ser
46d0: 76 65 72 2d 74 68 72 65 61 64 22 29 29 0a 09 09 ver-thread"))...
46e0: 20 28 72 75 6e 2d 74 68 72 65 61 64 20 28 6d 61 (run-thread (ma
46f0: 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 20 20 20 ke-thread....
4700: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
4710: 09 09 28 74 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 ..(tt:keep-runni
4720: 6e 67 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 ng ttdat dbfname
4730: 20 64 62 73 74 72 75 63 74 29 29 29 29 29 0a 09 dbstruct)))))..
4740: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
4750: 74 21 20 74 63 70 2d 74 68 72 65 61 64 29 0a 09 t! tcp-thread)..
4760: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
4770: 74 21 20 72 75 6e 2d 74 68 72 65 61 64 29 0a 09 t! run-thread)..
4780: 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e (thread-join
4790: 21 20 72 75 6e 2d 74 68 72 65 61 64 29 20 3b 3b ! run-thread) ;;
47a0: 20 72 75 6e 20 74 68 72 65 61 64 20 77 69 6c 6c run thread will
47b0: 20 65 78 69 74 20 6f 6e 20 74 69 6d 65 6f 75 74 exit on timeout
47c0: 20 6f 72 20 6f 74 68 65 72 20 63 6f 6e 64 69 74 or other condit
47d0: 69 6f 6e 73 0a 09 20 20 20 20 28 65 78 69 74 29 ions.. (exit)
47e0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
47f0: 74 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 tt:keep-running
4800: 74 74 64 61 74 20 64 62 66 6e 61 6d 65 20 64 62 ttdat dbfname db
4810: 73 74 72 75 63 74 29 0a 20 20 3b 3b 20 76 65 72 struct). ;; ver
4820: 66 69 79 20 63 6f 6e 6e 20 66 6f 72 20 72 65 61 fiy conn for rea
4830: 64 79 0a 20 20 3b 3b 20 6c 69 73 74 65 6e 65 72 dy. ;; listener
4840: 20 73 6f 63 6b 65 74 20 68 61 73 20 62 65 65 6e socket has been
4850: 20 73 74 61 72 74 65 64 20 62 79 20 74 68 69 73 started by this
4860: 20 73 74 61 67 65 0a 20 20 3b 3b 20 77 61 69 74 stage. ;; wait
4870: 20 66 6f 72 20 61 20 70 6f 72 74 20 62 65 66 6f for a port befo
4880: 72 65 20 63 72 65 61 74 69 6e 67 20 74 68 65 20 re creating the
4890: 72 65 67 69 73 74 72 61 74 69 6f 6e 20 66 69 6c registration fil
48a0: 65 0a 20 20 3b 3b 0a 20 20 28 6c 65 74 2a 20 28 e. ;;. (let* (
48b0: 28 64 62 2d 6c 6f 63 6b 65 64 2d 69 6e 20 23 66 (db-locked-in #f
48c0: 29 0a 09 20 28 61 72 65 61 70 61 74 68 20 20 20 ).. (areapath
48d0: 20 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 74 (tt-areapath t
48e0: 74 64 61 74 29 29 0a 09 20 28 6e 6f 73 79 6e 63 tdat)).. (nosync
48f0: 64 62 70 61 74 68 20 28 63 6f 6e 63 20 61 72 65 dbpath (conc are
4900: 61 70 61 74 68 22 2f 2e 6d 74 64 62 22 29 29 0a apath"/.mtdb")).
4910: 09 20 28 63 6c 65 61 6e 75 70 20 28 6c 61 6d 62 . (cleanup (lamb
4920: 64 61 20 28 29 0a 09 09 20 20 20 20 28 69 66 20 da ()... (if
4930: 28 74 74 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 (tt-cleanup-proc
4940: 20 74 74 64 61 74 29 0a 09 09 09 28 28 74 74 2d ttdat)....((tt-
4950: 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 74 74 64 cleanup-proc ttd
4960: 61 74 29 29 29 0a 09 09 20 20 20 20 28 64 62 66 at)))... (dbf
4970: 69 6c 65 3a 77 69 74 68 2d 6e 6f 2d 73 79 6e 63 ile:with-no-sync
4980: 2d 64 62 20 6e 6f 73 79 6e 63 64 62 70 61 74 68 -db nosyncdbpath
4990: 0a 09 09 09 09 09 20 20 20 20 28 6c 61 6d 62 64 ...... (lambd
49a0: 61 20 28 64 62 29 0a 09 09 09 09 09 20 20 20 20 a (db)......
49b0: 20 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 (db:no-sync-de
49c0: 6c 21 20 64 62 20 64 62 66 6e 61 6d 65 29 29 29 l! db dbfname)))
49d0: 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 73 ))). (set! *s
49e0: 65 72 76 65 72 2d 69 6e 66 6f 2a 20 74 74 64 61 erver-info* ttda
49f0: 74 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 t). (let loop
4a00: 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 ((count 0)).
4a10: 20 20 20 28 69 66 20 28 3e 20 63 6f 75 6e 74 20 (if (> count
4a20: 32 34 30 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 240).. (begin..
4a30: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4a40: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
4a50: 70 6f 72 74 2a 20 22 46 41 54 41 4c 3a 20 43 6f port* "FATAL: Co
4a60: 75 6c 64 20 6e 6f 74 20 73 74 61 72 74 20 61 20 uld not start a
4a70: 74 63 70 20 73 65 72 76 65 72 2c 20 67 69 76 69 tcp server, givi
4a80: 6e 67 20 75 70 2e 22 29 0a 09 20 20 20 20 28 65 ng up.").. (e
4a90: 78 69 74 20 31 29 29 0a 09 20 20 28 69 66 20 28 xit 1)).. (if (
4aa0: 6e 6f 74 20 28 74 74 2d 70 6f 72 74 20 74 74 64 not (tt-port ttd
4ab0: 61 74 29 29 20 3b 3b 20 6e 6f 20 63 6f 6e 6e 65 at)) ;; no conne
4ac0: 63 74 69 6f 6e 20 79 65 74 0a 09 20 20 20 20 20 ction yet..
4ad0: 20 28 62 65 67 69 6e 0a 09 09 28 74 68 72 65 61 (begin...(threa
4ae0: 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 d-sleep! 0.25)..
4af0: 09 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 .(loop (+ count
4b00: 31 29 29 29 29 29 29 0a 20 20 20 20 0a 20 20 20 1)))))). .
4b10: 20 28 74 74 3a 63 72 65 61 74 65 2d 73 65 72 76 (tt:create-serv
4b20: 65 72 2d 72 65 67 69 73 74 72 61 74 69 6f 6e 2d er-registration-
4b30: 66 69 6c 65 20 74 74 64 61 74 20 64 62 66 6e 61 file ttdat dbfna
4b40: 6d 65 29 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 73 me). ;; now s
4b50: 74 61 72 74 20 77 61 74 63 68 69 6e 67 20 74 68 tart watching th
4b60: 65 20 6c 61 73 74 2d 61 63 63 65 73 73 2c 20 69 e last-access, i
4b70: 66 20 69 74 20 68 61 73 6e 27 74 20 62 65 65 6e f it hasn't been
4b80: 20 74 6f 75 63 68 65 64 0a 20 20 20 20 3b 3b 20 touched. ;;
4b90: 69 6e 20 6f 76 65 72 20 74 65 6e 20 73 65 63 6f in over ten seco
4ba0: 6e 64 73 20 77 65 20 65 78 69 74 0a 20 20 20 20 nds we exit.
4bb0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
4bc0: 2e 30 35 29 20 3b 3b 20 61 6e 79 20 72 65 61 6c .05) ;; any real
4bd0: 20 6e 65 65 64 20 66 6f 72 20 64 65 6c 61 79 20 need for delay
4be0: 68 65 72 65 3f 0a 20 20 20 20 28 6c 65 74 20 6c here?. (let l
4bf0: 6f 6f 70 20 28 29 0a 20 20 20 20 20 20 28 6c 65 oop (). (le
4c00: 74 2a 20 28 28 73 65 72 76 65 72 73 20 28 74 74 t* ((servers (tt
4c10: 3a 67 65 74 2d 73 65 72 76 65 72 2d 69 6e 66 6f :get-server-info
4c20: 2d 73 6f 72 74 65 64 20 74 74 64 61 74 20 64 62 -sorted ttdat db
4c30: 66 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 28 6f fname)).. (o
4c40: 6b 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 k (cond...
4c50: 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 73 65 ((null? se
4c60: 72 76 65 72 73 29 20 23 66 29 20 3b 3b 20 6e 6f rvers) #f) ;; no
4c70: 74 20 6f 6b 0a 09 09 20 20 20 20 20 20 20 28 28 t ok... ((
4c80: 65 71 75 61 6c 3f 20 28 6c 69 73 74 2d 72 65 66 equal? (list-ref
4c90: 20 28 63 61 72 20 73 65 72 76 65 72 73 29 20 36 (car servers) 6
4ca0: 29 20 3b 3b 20 63 6f 6d 70 61 72 65 20 74 68 65 ) ;; compare the
4cb0: 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 0a 09 09 servinfofile...
4cc0: 09 09 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 69 ..(tt-servinf-fi
4cd0: 6c 65 20 74 74 64 61 74 29 29 0a 09 09 09 28 6c le ttdat))....(l
4ce0: 65 74 2a 20 28 28 72 65 73 20 28 69 66 20 64 62 et* ((res (if db
4cf0: 2d 6c 6f 63 6b 65 64 2d 69 6e 0a 09 09 09 09 09 -locked-in......
4d00: 23 74 0a 09 09 09 09 09 28 6c 65 74 2a 20 28 28 #t......(let* ((
4d10: 73 75 63 63 65 73 73 20 28 64 62 66 69 6c 65 3a success (dbfile:
4d20: 77 69 74 68 2d 6e 6f 2d 73 79 6e 63 2d 64 62 0a with-no-sync-db.
4d30: 09 09 09 09 09 09 09 20 6e 6f 73 79 6e 63 64 62 ....... nosyncdb
4d40: 70 61 74 68 0a 09 09 09 09 09 09 09 20 28 6c 61 path........ (la
4d50: 6d 62 64 61 20 28 64 62 29 0a 09 09 09 09 09 09 mbda (db).......
4d60: 09 20 20 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d . (db:no-sync-
4d70: 67 65 74 2d 6c 6f 63 6b 2d 77 69 74 68 2d 69 64 get-lock-with-id
4d80: 20 64 62 20 64 62 66 6e 61 6d 65 20 28 74 74 2d db dbfname (tt-
4d90: 73 65 72 76 69 6e 66 2d 66 69 6c 65 20 74 74 64 servinf-file ttd
4da0: 61 74 29 29 29 29 29 29 0a 09 09 09 09 09 20 20 at))))))......
4db0: 28 69 66 20 73 75 63 63 65 73 73 0a 09 09 09 09 (if success.....
4dc0: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
4dd0: 09 09 09 09 28 74 74 2d 73 74 61 74 65 2d 73 65 ....(tt-state-se
4de0: 74 21 20 74 74 64 61 74 20 27 72 75 6e 6e 69 6e t! ttdat 'runnin
4df0: 67 29 0a 09 09 09 09 09 09 28 64 65 62 75 67 3a g).......(debug:
4e00: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
4e10: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 47 6f 74 20 -log-port* "Got
4e20: 73 65 72 76 65 72 20 6c 6f 63 6b 20 66 6f 72 20 server lock for
4e30: 22 0a 09 09 09 09 09 09 09 20 20 20 20 20 64 62 "........ db
4e40: 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 28 73 65 fname).......(se
4e50: 74 21 20 64 62 2d 6c 6f 63 6b 65 64 2d 69 6e 20 t! db-locked-in
4e60: 23 74 29 0a 09 09 09 09 09 09 23 74 29 0a 09 09 #t).......#t)...
4e70: 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ... (begin.
4e80: 09 09 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 ......(debug:pri
4e90: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
4ea0: 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 g-port* "Failed
4eb0: 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 6c 6f to get server lo
4ec0: 63 6b 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 29 ck for "dbfname)
4ed0: 0a 09 09 09 09 09 09 23 66 29 29 29 29 29 29 0a .......#f)))))).
4ee0: 09 09 09 20 20 28 69 66 20 28 61 6e 64 20 72 65 ... (if (and re
4ef0: 73 0a 09 09 09 09 20 20 20 28 63 6f 6d 6d 6f 6e s..... (common
4f00: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
4f10: 20 31 32 30 20 22 74 6f 70 20 73 65 72 76 65 72 120 "top server
4f20: 20 6d 65 73 73 61 67 65 22 29 29 0a 09 09 09 20 message"))....
4f30: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
4f40: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
4f50: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4b 65 65 t-log-port* "Kee
4f60: 70 20 72 75 6e 6e 69 6e 67 2c 20 49 27 6d 20 74 p running, I'm t
4f70: 68 65 20 74 6f 70 20 73 65 72 76 65 72 20 66 6f he top server fo
4f80: 72 20 22 0a 09 09 09 09 09 09 64 62 66 6e 61 6d r ".......dbfnam
4f90: 65 22 20 6f 6e 20 22 28 74 74 2d 68 6f 73 74 20 e" on "(tt-host
4fa0: 74 74 64 61 74 29 22 3a 22 28 74 74 2d 70 6f 72 ttdat)":"(tt-por
4fb0: 74 20 74 74 64 61 74 29 29 29 0a 09 09 09 20 20 t ttdat)))....
4fc0: 72 65 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 res))... (
4fd0: 65 6c 73 65 0a 09 09 09 28 64 65 62 75 67 3a 70 else....(debug:p
4fe0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
4ff0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5000: 49 27 6d 20 6e 6f 74 20 74 68 65 20 6c 65 61 64 I'm not the lead
5010: 20 73 65 72 76 65 72 3a 20 22 73 65 72 76 65 72 server: "server
5020: 73 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 6c 65 s)....(let* ((le
5030: 61 64 73 72 76 20 28 63 61 72 20 73 65 72 76 65 adsrv (car serve
5040: 72 73 29 29 29 0a 09 09 09 20 20 28 6d 61 74 63 rs))).... (matc
5050: 68 20 6c 65 61 64 73 72 76 0a 09 09 09 20 20 20 h leadsrv....
5060: 20 28 28 68 6f 73 74 20 70 6f 72 74 20 73 74 61 ((host port sta
5070: 72 74 73 65 63 6f 6e 64 73 20 73 65 72 76 65 72 rtseconds server
5080: 2d 69 64 20 70 69 64 20 64 62 66 6e 61 6d 65 20 -id pid dbfname
5090: 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a 09 09 servinfofile)...
50a0: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 . (let* ((re
50b0: 73 20 20 28 74 74 3a 70 69 6e 67 20 68 6f 73 74 s (tt:ping host
50c0: 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 29 port server-id)
50d0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 )).... (de
50e0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
50f0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5100: 72 74 2a 20 22 50 69 6e 67 20 74 6f 20 22 68 6f rt* "Ping to "ho
5110: 73 74 22 3a 22 70 6f 72 74 22 2c 20 77 69 74 68 st":"port", with
5120: 20 73 65 72 76 65 72 2d 69 64 20 22 73 65 72 76 server-id "serv
5130: 65 72 2d 69 64 0a 09 09 09 09 09 09 20 22 2c 20 er-id....... ",
5140: 61 6e 64 20 66 69 6c 65 20 22 73 65 72 76 69 6e and file "servin
5150: 66 6f 66 69 6c 65 22 20 72 65 74 75 72 6e 65 64 fofile" returned
5160: 20 22 72 65 73 29 0a 09 09 09 20 20 20 20 20 20 "res)....
5170: 20 28 69 66 20 72 65 73 0a 09 09 09 09 20 20 20 (if res.....
5180: 23 66 20 3b 3b 20 6e 6f 74 20 74 68 65 20 73 65 #f ;; not the se
5190: 72 76 65 72 2c 20 62 75 74 20 61 6c 6c 20 67 6f rver, but all go
51a0: 6f 64 2c 20 77 61 6e 74 20 74 6f 20 65 78 69 74 od, want to exit
51b0: 0a 09 09 09 09 20 20 20 28 69 66 20 28 61 6e 64 ..... (if (and
51c0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 (file-exists? s
51d0: 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a 09 09 09 ervinfofile)....
51e0: 09 09 20 20 28 3e 20 28 2d 20 28 63 75 72 72 65 .. (> (- (curre
51f0: 6e 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 nt-seconds)(file
5200: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
5210: 6d 65 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 me servinfofile)
5220: 29 20 33 30 29 29 0a 09 09 09 09 20 20 20 20 20 ) 30)).....
5230: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 (begin.....
5240: 20 20 3b 3b 20 63 61 6e 27 74 20 70 69 6e 67 20 ;; can't ping
5250: 61 6e 64 20 66 69 6c 65 20 68 61 73 20 62 65 65 and file has bee
5260: 6e 20 6f 6e 20 64 69 73 6b 20 31 35 20 73 65 63 n on disk 15 sec
5270: 6f 6e 64 73 2c 20 67 6f 20 61 68 65 61 64 20 61 onds, go ahead a
5280: 6e 64 20 74 72 79 20 74 6f 20 72 65 6d 6f 76 65 nd try to remove
5290: 20 69 74 0a 09 09 09 09 20 20 20 20 20 20 20 28 it..... (
52a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
52b0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
52c0: 70 6f 72 74 2a 20 22 52 65 6d 6f 76 69 6e 67 20 port* "Removing
52d0: 61 70 70 61 72 65 6e 74 6c 79 20 64 65 61 64 20 apparently dead
52e0: 73 65 72 76 65 72 20 69 6e 66 6f 20 66 69 6c 65 server info file
52f0: 3a 20 22 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 : "servinfofile)
5300: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5320: 20 20 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d (handle-
5330: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
5340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5360: 20 20 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 exn.
5370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5390: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
53a0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
53b0: 70 6f 72 74 2a 20 22 45 72 72 6f 72 20 72 65 6d port* "Error rem
53c0: 6f 76 69 6e 67 20 73 65 72 76 65 72 20 69 6e 66 oving server inf
53d0: 6f 20 66 69 6c 65 3a 20 22 73 65 72 76 69 6e 66 o file: "servinf
53e0: 6f 66 69 6c 65 29 0a 09 09 09 09 20 20 20 20 20 ofile).....
53f0: 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a (delete-file*
5400: 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a 20 servinfofile).
5410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5430: 20 20 20 20 20 20 29 0a 09 09 09 09 20 20 20 20 ).....
5440: 20 20 20 23 74 29 20 3b 3b 20 6e 6f 74 20 74 68 #t) ;; not th
5450: 65 20 73 65 72 76 65 72 20 62 75 74 20 74 68 65 e server but the
5460: 20 73 65 72 76 65 72 20 69 73 20 6e 6f 74 20 72 server is not r
5470: 65 61 63 68 61 62 6c 65 0a 09 09 09 09 20 20 20 eachable.....
5480: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
5490: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
54a0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
54b0: 70 6f 72 74 2a 20 22 49 27 6d 20 6e 6f 74 20 74 port* "I'm not t
54c0: 68 65 20 73 65 72 76 65 72 20 62 75 74 20 63 6f he server but co
54d0: 75 6c 64 20 6e 6f 74 20 70 69 6e 67 20 22 68 6f uld not ping "ho
54e0: 73 74 22 3a 22 70 6f 72 74 22 2c 20 77 69 6c 6c st":"port", will
54f0: 20 74 72 79 20 61 67 61 69 6e 2e 22 29 0a 09 09 try again.")...
5500: 09 09 20 20 20 20 20 20 20 28 74 68 72 65 61 64 .. (thread
5510: 2d 73 6c 65 65 70 21 20 31 29 20 3b 3b 20 6a 75 -sleep! 1) ;; ju
5520: 73 74 20 62 65 63 61 75 73 65 0a 09 09 09 09 20 st because.....
5530: 20 20 20 20 20 20 23 74 29 29 29 29 29 0a 09 09 #t)))))...
5540: 09 20 20 20 20 28 65 6c 73 65 20 3b 3b 20 73 68 . (else ;; sh
5550: 6f 75 6c 64 20 6e 65 76 65 72 20 67 65 74 20 68 ould never get h
5560: 65 72 65 0a 09 09 09 20 20 20 20 20 28 64 65 62 ere.... (deb
5570: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
5580: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 42 ult-log-port* "B
5590: 41 44 20 53 45 52 56 45 52 20 52 45 43 4f 52 44 AD SERVER RECORD
55a0: 3a 20 22 6c 65 61 64 73 72 76 29 0a 09 09 09 20 : "leadsrv)....
55b0: 20 20 20 20 28 61 73 73 65 72 74 20 23 66 20 22 (assert #f "
55c0: 42 61 64 20 73 65 72 76 65 72 20 72 65 63 6f 72 Bad server recor
55d0: 64 20 22 6c 65 61 64 73 72 76 29 29 29 29 29 29 d "leadsrv))))))
55e0: 29 29 0a 09 28 69 66 20 6f 6b 0a 09 20 20 20 20 ))..(if ok..
55f0: 3b 3b 20 28 69 66 20 28 3e 20 2a 61 70 69 2d 70 ;; (if (> *api-p
5600: 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 rocess-request-c
5610: 6f 75 6e 74 2a 20 30 29 20 3b 3b 20 68 61 76 65 ount* 0) ;; have
5620: 20 72 65 71 75 65 73 74 73 20 69 6e 20 66 6c 69 requests in fli
5630: 67 68 74 0a 09 20 20 20 20 3b 3b 09 28 74 74 2d ght.. ;;.(tt-
5640: 6c 61 73 74 2d 61 63 63 65 73 73 2d 73 65 74 21 last-access-set!
5650: 20 74 74 64 61 74 20 28 63 75 72 72 65 6e 74 2d ttdat (current-
5660: 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 20 20 20 seconds)))..
5670: 28 74 74 2d 6c 61 73 74 2d 61 63 63 65 73 73 2d (tt-last-access-
5680: 73 65 74 21 20 74 74 64 61 74 20 2a 64 62 2d 6c set! ttdat *db-l
5690: 61 73 74 2d 61 63 63 65 73 73 2a 29 20 3b 3b 20 ast-access*) ;;
56a0: 62 69 74 20 73 69 6c 6c 79 2c 20 6a 75 73 74 20 bit silly, just
56b0: 75 73 65 20 64 62 2d 6c 61 73 74 2d 61 63 63 65 use db-last-acce
56c0: 73 73 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 ss.. (begin..
56d0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
56e0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
56f0: 67 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 g-port* "Exiting
5700: 20 69 6d 6d 65 64 69 61 74 65 6c 79 22 29 0a 09 immediately")..
5710: 20 20 20 20 20 20 28 63 6c 65 61 6e 75 70 29 0a (cleanup).
5720: 09 20 20 20 20 20 20 28 65 78 69 74 29 29 29 0a . (exit))).
5730: 0a 09 28 6c 65 74 2a 20 28 28 6c 61 73 74 2d 75 ..(let* ((last-u
5740: 70 64 61 74 65 20 28 64 62 72 3a 64 62 73 74 72 pdate (dbr:dbstr
5750: 75 63 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 uct-last-update
5760: 64 62 73 74 72 75 63 74 29 29 0a 09 20 20 20 20 dbstruct))..
5770: 20 20 20 28 63 75 72 72 2d 73 65 63 73 20 20 20 (curr-secs
5780: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
5790: 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 ))).. (if (and
57a0: 28 65 71 3f 20 28 74 74 2d 73 74 61 74 65 20 74 (eq? (tt-state t
57b0: 74 64 61 74 29 20 27 72 75 6e 6e 69 6e 67 29 0a tdat) 'running).
57c0: 09 09 20 20 20 28 3e 20 28 2d 20 63 75 72 72 2d .. (> (- curr-
57d0: 73 65 63 73 20 6c 61 73 74 2d 75 70 64 61 74 65 secs last-update
57e0: 29 20 33 29 29 20 3b 3b 20 65 76 65 72 79 20 33 ) 3)) ;; every 3
57f0: 2d 34 20 73 65 63 6f 6e 64 73 20 75 70 64 61 74 -4 seconds updat
5800: 65 20 74 68 65 20 64 62 3f 20 6d 61 79 62 65 20 e the db? maybe
5810: 74 68 69 73 20 73 68 6f 75 6c 64 20 62 65 20 72 this should be r
5820: 65 66 72 65 73 68 20 74 68 65 20 69 6e 6d 65 6d efresh the inmem
5830: 3f 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ?.. (begin.
5840: 09 09 28 73 65 74 21 20 28 66 69 6c 65 2d 6d 6f ..(set! (file-mo
5850: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
5860: 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 69 6c 65 (tt-servinf-file
5870: 20 74 74 64 61 74 29 29 20 28 63 75 72 72 65 6e ttdat)) (curren
5880: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 28 28 t-seconds))...((
5890: 64 62 72 3a 64 62 73 74 72 75 63 74 2d 73 79 6e dbr:dbstruct-syn
58a0: 63 2d 70 72 6f 63 20 64 62 73 74 72 75 63 74 29 c-proc dbstruct)
58b0: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 0a 09 09 last-update)...
58c0: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 6c 61 (dbr:dbstruct-la
58d0: 73 74 2d 75 70 64 61 74 65 2d 73 65 74 21 20 64 st-update-set! d
58e0: 62 73 74 72 75 63 74 20 63 75 72 72 2d 73 65 63 bstruct curr-sec
58f0: 73 29 29 29 29 0a 09 20 20 0a 09 28 69 66 20 28 s)))).. ..(if (
5900: 3c 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 < (- (current-se
5910: 63 6f 6e 64 73 29 20 28 74 74 2d 6c 61 73 74 2d conds) (tt-last-
5920: 61 63 63 65 73 73 20 74 74 64 61 74 29 29 20 28 access ttdat)) (
5930: 74 74 2d 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 tt-server-timeou
5940: 74 2d 70 61 72 61 6d 29 29 0a 09 20 20 20 20 28 t-param)).. (
5950: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 74 68 begin.. (th
5960: 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 read-sleep! 5)..
5970: 20 20 20 20 20 20 28 6c 6f 6f 70 29 29 29 29 29 (loop)))))
5980: 0a 20 20 20 20 28 63 6c 65 61 6e 75 70 29 0a 20 . (cleanup).
5990: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
59a0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
59b0: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 53 65 72 76 ort* "INFO: Serv
59c0: 65 72 20 74 69 6d 65 64 20 6f 75 74 2c 20 65 78 er timed out, ex
59d0: 69 74 69 6e 67 2e 22 29 29 29 0a 0a 20 20 0a 3b iting."))).. .;
59e0: 3b 20 3b 3b 20 67 69 76 65 6e 20 61 6e 20 61 6c ; ;; given an al
59f0: 72 65 61 64 79 20 73 65 74 20 75 70 20 75 63 6f ready set up uco
5a00: 6e 6e 20 73 74 61 72 74 20 74 68 65 20 63 6d 64 nn start the cmd
5a10: 2d 6c 6f 6f 70 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 -loop.;; ;;.;; (
5a20: 64 65 66 69 6e 65 20 28 74 74 3a 63 6d 64 2d 6c define (tt:cmd-l
5a30: 6f 6f 70 20 74 74 64 61 74 29 0a 3b 3b 20 20 20 oop ttdat).;;
5a40: 28 6c 65 74 2a 20 28 28 73 65 72 76 2d 6c 69 73 (let* ((serv-lis
5a50: 74 65 6e 65 72 20 28 2d 73 6f 63 6b 65 74 20 75 tener (-socket u
5a60: 63 6f 6e 6e 29 29 0a 3b 3b 20 09 20 28 6c 69 73 conn)).;; . (lis
5a70: 74 65 6e 65 72 20 20 20 20 20 20 28 6c 61 6d 62 tener (lamb
5a80: 64 61 20 28 29 0a 3b 3b 20 09 09 09 20 20 28 6c da ().;; ... (l
5a90: 65 74 20 6c 6f 6f 70 20 28 28 73 74 61 74 65 20 et loop ((state
5aa0: 27 73 74 61 72 74 29 29 0a 3b 3b 20 09 09 09 20 'start)).;; ...
5ab0: 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 (let-values (
5ac0: 28 28 69 6e 70 20 6f 75 70 29 28 74 63 70 2d 61 ((inp oup)(tcp-a
5ad0: 63 63 65 70 74 20 73 65 72 76 2d 6c 69 73 74 65 ccept serv-liste
5ae0: 6e 65 72 29 29 29 0a 3b 3b 20 09 09 09 20 20 20 ner))).;; ...
5af0: 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 ;; (mutex-loc
5b00: 6b 21 20 2a 73 65 6e 64 2d 6d 75 74 65 78 2a 29 k! *send-mutex*)
5b10: 20 3b 3b 20 44 4f 45 53 4e 27 54 20 53 45 45 4d ;; DOESN'T SEEM
5b20: 20 54 4f 20 48 45 4c 50 0a 3b 3b 20 09 09 09 20 TO HELP.;; ...
5b30: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 64 61 (let* ((rda
5b40: 74 20 20 28 64 65 73 65 72 69 61 6c 69 7a 65 20 t (deserialize
5b50: 69 6e 70 29 29 20 3b 3b 20 27 28 6d 79 2d 68 6f inp)) ;; '(my-ho
5b60: 73 74 2d 70 6f 72 74 20 71 72 79 6b 65 79 20 63 st-port qrykey c
5b70: 6d 64 20 70 61 72 61 6d 73 29 0a 3b 3b 20 09 09 md params).;; ..
5b80: 09 09 20 20 20 20 20 28 72 65 73 70 20 20 28 75 .. (resp (u
5b90: 6c 65 78 2d 68 61 6e 64 6c 65 72 20 75 63 6f 6e lex-handler ucon
5ba0: 6e 20 72 64 61 74 29 29 29 0a 3b 3b 20 09 09 09 n rdat))).;; ...
5bb0: 09 28 73 65 72 69 61 6c 69 7a 65 20 72 65 73 70 .(serialize resp
5bc0: 20 6f 75 70 29 0a 3b 3b 20 09 09 09 09 28 63 6c oup).;; ....(cl
5bd0: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 ose-input-port i
5be0: 6e 70 29 0a 3b 3b 20 09 09 09 09 28 63 6c 6f 73 np).;; ....(clos
5bf0: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 e-output-port ou
5c00: 70 29 0a 3b 3b 20 09 09 09 09 3b 3b 20 28 6d 75 p).;; ....;; (mu
5c10: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 73 65 6e tex-unlock! *sen
5c20: 64 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 44 4f 45 d-mutex*) ;; DOE
5c30: 53 4e 27 54 20 53 45 45 4d 20 54 4f 20 48 45 4c SN'T SEEM TO HEL
5c40: 50 0a 3b 3b 20 09 09 09 09 29 0a 3b 3b 20 09 09 P.;; ....).;; ..
5c50: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 73 74 61 . (loop sta
5c60: 74 65 29 29 29 29 29 29 0a 3b 3b 20 20 20 20 20 te)))))).;;
5c70: 3b 3b 20 73 74 61 72 74 20 4e 20 6f 66 20 74 68 ;; start N of th
5c80: 65 6d 0a 3b 3b 20 20 20 20 20 28 6c 65 74 20 6c em.;; (let l
5c90: 6f 6f 70 20 28 28 74 68 6e 75 6d 20 20 20 30 29 oop ((thnum 0)
5ca0: 0a 3b 3b 20 09 20 20 20 20 20 20 20 28 74 68 72 .;; . (thr
5cb0: 65 61 64 73 20 27 28 29 29 29 0a 3b 3b 20 20 20 eads '())).;;
5cc0: 20 20 20 20 28 69 66 20 28 3c 20 74 68 6e 75 6d (if (< thnum
5cd0: 20 31 30 30 29 0a 3b 3b 20 09 20 20 28 6c 65 74 100).;; . (let
5ce0: 2a 20 28 28 74 68 20 28 6d 61 6b 65 2d 74 68 72 * ((th (make-thr
5cf0: 65 61 64 20 6c 69 73 74 65 6e 65 72 20 28 63 6f ead listener (co
5d00: 6e 63 20 22 6c 69 73 74 65 6e 65 72 22 20 74 68 nc "listener" th
5d10: 6e 75 6d 29 29 29 29 0a 3b 3b 20 09 20 20 20 20 num)))).;; .
5d20: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
5d30: 68 29 0a 3b 3b 20 09 20 20 20 20 28 6c 6f 6f 70 h).;; . (loop
5d40: 20 28 2b 20 74 68 6e 75 6d 20 31 29 0a 3b 3b 20 (+ thnum 1).;;
5d50: 09 09 20 20 28 63 6f 6e 73 20 74 68 20 74 68 72 .. (cons th thr
5d60: 65 61 64 73 29 29 29 0a 3b 3b 20 09 20 20 28 6d eads))).;; . (m
5d70: 61 70 20 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 ap thread-join!
5d80: 74 68 72 65 61 64 73 29 29 29 29 29 0a 3b 3b 20 threads))))).;;
5d90: 0a 3b 3b 20 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 .;; .;; .;; (def
5da0: 69 6e 65 20 28 77 61 69 74 2d 61 6e 64 2d 63 6c ine (wait-and-cl
5db0: 6f 73 65 20 75 63 6f 6e 6e 29 0a 3b 3b 20 20 20 ose uconn).;;
5dc0: 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 28 75 (thread-join! (u
5dd0: 64 61 74 2d 63 6d 64 2d 74 68 72 65 61 64 20 75 dat-cmd-thread u
5de0: 63 6f 6e 6e 29 29 0a 3b 3b 20 20 20 28 74 63 70 conn)).;; (tcp
5df0: 2d 63 6c 6f 73 65 20 28 75 64 61 74 2d 73 6f 63 -close (udat-soc
5e00: 6b 65 74 20 75 63 6f 6e 6e 29 29 29 0a 3b 3b 20 ket uconn))).;;
5e10: 0a 3b 3b 20 0a 0a 28 64 65 66 69 6e 65 20 28 74 .;; ..(define (t
5e20: 74 3a 73 68 75 74 64 6f 77 6e 2d 73 65 72 76 65 t:shutdown-serve
5e30: 72 20 74 74 64 61 74 29 0a 20 20 28 6c 65 74 2a r ttdat). (let*
5e40: 20 28 28 63 6c 65 61 6e 70 72 6f 63 20 28 74 74 ((cleanproc (tt
5e50: 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 74 74 -cleanup-proc tt
5e60: 64 61 74 29 29 0a 09 20 28 70 6f 72 74 20 20 20 dat)).. (port
5e70: 20 20 20 28 74 74 2d 70 6f 72 74 20 20 20 20 20 (tt-port
5e80: 20 20 20 20 74 74 64 61 74 29 29 29 0a 20 20 20 ttdat))).
5e90: 20 28 74 74 2d 73 74 61 74 65 2d 73 65 74 21 20 (tt-state-set!
5ea0: 74 74 64 61 74 20 27 73 68 75 74 64 6f 77 6e 29 ttdat 'shutdown)
5eb0: 0a 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 . (portlogger
5ec0: 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 :open-run-close
5ed0: 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d 70 portlogger:set-p
5ee0: 6f 72 74 20 70 6f 72 74 20 22 72 65 6c 65 61 73 ort port "releas
5ef0: 65 64 22 29 0a 20 20 20 20 28 69 66 20 63 6c 65 ed"). (if cle
5f00: 61 6e 70 72 6f 63 20 28 63 6c 65 61 6e 70 72 6f anproc (cleanpro
5f10: 63 29 29 0a 20 20 20 20 28 74 63 70 2d 63 6c 6f c)). (tcp-clo
5f20: 73 65 20 28 74 74 2d 73 6f 63 6b 65 74 20 74 74 se (tt-socket tt
5f30: 64 61 74 29 29 20 3b 3b 20 63 6c 6f 73 65 20 75 dat)) ;; close u
5f40: 70 20 70 6f 72 74 73 20 68 65 72 65 0a 20 20 20 p ports here.
5f50: 20 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 ))..;; (define
5f60: 28 77 61 69 74 2d 61 6e 64 2d 63 6c 6f 73 65 20 (wait-and-close
5f70: 75 63 6f 6e 6e 29 0a 3b 3b 20 20 20 28 74 68 72 uconn).;; (thr
5f80: 65 61 64 2d 6a 6f 69 6e 21 20 28 74 74 2d 63 6d ead-join! (tt-cm
5f90: 64 2d 74 68 72 65 61 64 20 75 63 6f 6e 6e 29 29 d-thread uconn))
5fa0: 0a 3b 3b 20 20 20 28 74 63 70 2d 63 6c 6f 73 65 .;; (tcp-close
5fb0: 20 28 74 74 2d 73 6f 63 6b 65 74 20 75 63 6f 6e (tt-socket ucon
5fc0: 6e 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 n)))..;; return
5fd0: 73 65 72 76 69 64 0a 3b 3b 20 73 69 64 65 2d 65 servid.;; side-e
5fe0: 66 66 65 63 74 73 3a 0a 3b 3b 20 20 20 74 74 64 ffects:.;; ttd
5ff0: 61 74 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 at-cleanup-proc
6000: 69 73 20 70 6f 70 75 6c 61 74 65 64 20 77 69 74 is populated wit
6010: 68 20 66 75 6e 63 74 69 6f 6e 20 74 6f 20 72 65 h function to re
6020: 6d 6f 76 65 20 74 68 65 20 73 65 72 76 65 72 69 move the serveri
6030: 6e 66 6f 20 66 69 6c 65 0a 28 64 65 66 69 6e 65 nfo file.(define
6040: 20 28 74 74 3a 63 72 65 61 74 65 2d 73 65 72 76 (tt:create-serv
6050: 65 72 2d 72 65 67 69 73 74 72 61 74 69 6f 6e 2d er-registration-
6060: 66 69 6c 65 20 74 74 64 61 74 20 64 62 66 6e 61 file ttdat dbfna
6070: 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 72 me). (let* ((ar
6080: 65 61 70 61 74 68 20 28 74 74 2d 61 72 65 61 70 eapath (tt-areap
6090: 61 74 68 20 74 74 64 61 74 29 29 0a 09 20 28 73 ath ttdat)).. (s
60a0: 65 72 76 64 69 72 20 20 28 74 74 3a 67 65 74 2d ervdir (tt:get-
60b0: 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 servinfo-dir are
60c0: 61 70 61 74 68 29 29 0a 09 20 28 68 6f 73 74 20 apath)).. (host
60d0: 20 20 20 20 28 74 74 2d 68 6f 73 74 20 74 74 64 (tt-host ttd
60e0: 61 74 29 29 0a 09 20 28 70 6f 72 74 20 20 20 20 at)).. (port
60f0: 20 28 74 74 2d 70 6f 72 74 20 74 74 64 61 74 29 (tt-port ttdat)
6100: 29 0a 09 20 28 73 65 72 76 69 6e 66 20 28 63 6f ).. (servinf (co
6110: 6e 63 20 73 65 72 76 64 69 72 22 2f 22 68 6f 73 nc servdir"/"hos
6120: 74 22 3a 22 70 6f 72 74 22 2d 22 28 63 75 72 72 t":"port"-"(curr
6130: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 ent-process-id)"
6140: 3a 22 64 62 66 6e 61 6d 65 29 29 0a 09 20 28 73 :"dbfname)).. (s
6150: 65 72 76 2d 69 64 20 28 74 74 3a 6d 6b 2d 73 69 erv-id (tt:mk-si
6160: 67 6e 61 74 75 72 65 20 61 72 65 61 70 61 74 68 gnature areapath
6170: 29 29 0a 09 20 28 63 6c 65 61 6e 2d 70 72 6f 63 )).. (clean-proc
6180: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 (lambda ()...
6190: 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c (delete-fil
61a0: 65 2a 20 73 65 72 76 69 6e 66 29 29 29 29 0a 20 e* servinf)))).
61b0: 20 20 20 28 61 73 73 65 72 74 20 28 61 6e 64 20 (assert (and
61c0: 68 6f 73 74 20 70 6f 72 74 29 20 22 46 41 54 41 host port) "FATA
61d0: 4c 3a 20 74 74 3a 63 72 65 61 74 65 2d 73 65 72 L: tt:create-ser
61e0: 76 65 72 2d 72 65 67 69 73 74 72 61 74 69 6f 6e ver-registration
61f0: 2d 66 69 6c 65 20 63 61 6c 6c 65 64 20 77 69 74 -file called wit
6200: 68 20 6e 6f 20 63 6f 6e 6e 2c 20 64 62 66 6e 61 h no conn, dbfna
6210: 6d 65 3d 22 64 62 66 6e 61 6d 65 29 0a 20 20 20 me="dbfname).
6220: 20 28 74 74 2d 63 6c 65 61 6e 75 70 2d 70 72 6f (tt-cleanup-pro
6230: 63 2d 73 65 74 21 20 74 74 64 61 74 20 63 6c 65 c-set! ttdat cle
6240: 61 6e 2d 70 72 6f 63 29 0a 20 20 20 20 28 74 74 an-proc). (tt
6250: 2d 73 65 72 76 69 6e 66 2d 66 69 6c 65 2d 73 65 -servinf-file-se
6260: 74 21 20 74 74 64 61 74 20 73 65 72 76 69 6e 66 t! ttdat servinf
6270: 29 0a 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 ). (with-outp
6280: 75 74 2d 74 6f 2d 66 69 6c 65 20 73 65 72 76 69 ut-to-file servi
6290: 6e 66 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 nf. (lambda
62a0: 20 28 29 0a 09 28 70 72 69 6e 74 20 22 53 45 52 ()..(print "SER
62b0: 56 45 52 20 53 54 41 52 54 45 44 3a 20 22 68 6f VER STARTED: "ho
62c0: 73 74 22 3a 22 70 6f 72 74 22 20 41 54 20 22 28 st":"port" AT "(
62d0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
62e0: 22 20 73 65 72 76 65 72 2d 69 64 3a 20 22 73 65 " server-id: "se
62f0: 72 76 2d 69 64 22 20 70 69 64 3a 20 22 28 63 75 rv-id" pid: "(cu
6300: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
6310: 29 22 20 64 62 66 6e 61 6d 65 3a 20 22 64 62 66 )" dbfname: "dbf
6320: 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 73 65 name))). se
6330: 72 76 2d 69 64 29 29 0a 0a 3b 3b 20 66 69 6e 64 rv-id))..;; find
6340: 20 76 61 6c 69 64 20 73 65 72 76 65 72 0a 3b 3b valid server.;;
6350: 20 67 65 74 20 73 65 72 76 65 72 73 20 6c 69 73 get servers lis
6360: 74 65 64 2c 20 6c 61 73 74 20 70 61 72 74 20 6f ted, last part o
6370: 66 20 6e 61 6d 65 20 6d 75 73 74 20 6d 61 74 63 f name must matc
6380: 68 20 3a 3c 64 62 66 6e 61 6d 65 3e 0a 3b 3b 20 h :<dbfname>.;;
6390: 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 6f 6e 65 if more than one
63a0: 2c 20 77 61 69 74 20 6f 6e 65 20 73 65 63 6f 6e , wait one secon
63b0: 64 20 61 6e 64 20 6c 6f 6f 6b 20 61 67 61 69 6e d and look again
63c0: 0a 3b 3b 20 66 75 74 75 72 65 3a 20 70 69 6e 67 .;; future: ping
63d0: 20 6f 6c 64 65 73 74 2c 20 69 66 20 61 6c 69 76 oldest, if aliv
63e0: 65 20 72 65 6d 6f 76 65 20 6f 74 68 65 72 20 3a e remove other :
63f0: 3c 64 62 66 6e 61 6d 65 3e 20 66 69 6c 65 73 0a <dbfname> files.
6400: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 66 ;;.(define (tt:f
6410: 69 6e 64 2d 73 65 72 76 65 72 20 61 72 65 61 70 ind-server areap
6420: 61 74 68 20 64 62 66 6e 61 6d 65 29 0a 20 20 28 ath dbfname). (
6430: 6c 65 74 2a 20 28 28 73 65 72 76 64 69 72 20 20 let* ((servdir
6440: 28 74 74 3a 67 65 74 2d 73 65 72 76 69 6e 66 6f (tt:get-servinfo
6450: 2d 64 69 72 20 61 72 65 61 70 61 74 68 29 29 0a -dir areapath)).
6460: 09 20 28 73 66 69 6c 65 73 20 20 20 28 67 6c 6f . (sfiles (glo
6470: 62 20 28 63 6f 6e 63 20 73 65 72 76 64 69 72 22 b (conc servdir"
6480: 2f 2a 3a 22 64 62 66 6e 61 6d 65 29 29 29 29 0a /*:"dbfname)))).
6490: 20 20 20 20 73 66 69 6c 65 73 29 29 0a 0a 3b 3b sfiles))..;;
64a0: 20 67 69 76 65 6e 20 61 20 70 61 74 68 20 74 6f given a path to
64b0: 20 61 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 a server info f
64c0: 69 6c 65 20 72 65 74 75 72 6e 3a 20 68 6f 73 74 ile return: host
64d0: 20 70 6f 72 74 20 73 74 61 72 74 73 65 63 6f 6e port startsecon
64e0: 64 73 20 73 65 72 76 65 72 2d 69 64 20 70 69 64 ds server-id pid
64f0: 20 64 62 66 6e 61 6d 65 20 6c 6f 67 66 0a 3b 3b dbfname logf.;;
6500: 20 65 78 61 6d 70 6c 65 20 6f 66 20 77 68 61 74 example of what
6510: 20 69 74 27 73 20 6c 6f 6f 6b 69 6e 67 20 66 6f it's looking fo
6520: 72 20 69 6e 20 74 68 65 20 6c 6f 67 20 66 69 6c r in the log fil
6530: 65 3a 0a 3b 3b 20 20 20 20 20 53 45 52 56 45 52 e:.;; SERVER
6540: 20 53 54 41 52 54 45 44 3a 20 31 30 2e 33 38 2e STARTED: 10.38.
6550: 31 37 35 2e 36 37 3a 35 30 32 31 36 20 41 54 20 175.67:50216 AT
6560: 31 36 31 36 35 30 32 33 35 30 2e 30 20 73 65 72 1616502350.0 ser
6570: 76 65 72 2d 69 64 3a 20 34 39 30 37 65 39 30 66 ver-id: 4907e90f
6580: 63 35 35 63 37 61 30 39 36 39 34 65 33 66 36 35 c55c7a09694e3f65
6590: 38 63 36 33 39 63 66 34 20 0a 3b 3b 0a 28 64 65 8c639cf4 .;;.(de
65a0: 66 69 6e 65 20 28 74 74 3a 73 65 72 76 65 72 2d fine (tt:server-
65b0: 67 65 74 2d 69 6e 66 6f 20 6c 6f 67 66 29 0a 20 get-info logf).
65c0: 20 28 6c 65 74 20 28 28 73 65 72 76 65 72 2d 72 (let ((server-r
65d0: 78 20 20 20 20 28 72 65 67 65 78 70 20 22 5e 53 x (regexp "^S
65e0: 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 28 ERVER STARTED: (
65f0: 5c 5c 53 2b 29 3a 28 5c 5c 64 2b 29 20 41 54 20 \\S+):(\\d+) AT
6600: 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 20 73 65 72 76 ([\\d\\.]+) serv
6610: 65 72 2d 69 64 3a 20 28 5c 5c 53 2b 29 20 70 69 er-id: (\\S+) pi
6620: 64 3a 20 28 5c 5c 64 2b 29 20 64 62 66 6e 61 6d d: (\\d+) dbfnam
6630: 65 3a 20 28 5c 5c 53 2b 29 22 29 29 20 3b 3b 20 e: (\\S+)")) ;;
6640: 53 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 SERVER STARTED:
6650: 68 6f 73 74 3a 70 6f 72 74 20 41 54 20 74 69 6d host:port AT tim
6660: 65 73 65 63 73 20 73 65 72 76 65 72 20 69 64 0a esecs server id.
6670: 20 20 20 20 20 20 20 20 28 64 62 70 72 65 70 2d (dbprep-
6680: 72 78 20 20 20 20 28 72 65 67 65 78 70 20 22 5e rx (regexp "^
6690: 53 45 52 56 45 52 3a 20 64 62 70 72 65 70 22 29 SERVER: dbprep")
66a0: 29 0a 20 20 20 20 20 20 20 20 28 64 62 70 72 65 ). (dbpre
66b0: 70 2d 66 6f 75 6e 64 20 30 29 0a 09 28 62 61 64 p-found 0)..(bad
66c0: 2d 64 61 74 20 20 20 20 20 20 28 6c 69 73 74 20 -dat (list
66d0: 23 66 20 23 66 20 23 66 20 23 66 20 23 66 20 23 #f #f #f #f #f #
66e0: 66 20 6c 6f 67 66 29 29 29 0a 20 20 20 20 20 28 f logf))). (
66f0: 6c 65 74 20 28 28 66 64 61 74 20 20 20 20 20 28 let ((fdat (
6700: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
6710: 73 0a 09 09 09 20 65 78 6e 0a 09 09 20 20 20 20 s.... exn...
6720: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 3b 3b (begin.... ;;
6730: 20 57 41 52 4e 49 4e 47 3a 20 74 68 69 73 20 69 WARNING: this i
6740: 73 20 70 6f 74 65 6e 74 69 61 6c 6c 79 20 64 61 s potentially da
6750: 6e 67 65 72 6f 75 73 20 74 6f 20 62 6c 61 6e 6b ngerous to blank
6760: 65 74 20 69 67 6e 6f 72 65 20 74 68 65 20 65 72 et ignore the er
6770: 72 6f 72 73 0a 09 09 09 20 28 64 65 62 75 67 3a rors.... (debug:
6780: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
6790: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
67a0: 22 55 6e 61 62 6c 65 20 74 6f 20 67 65 74 20 73 "Unable to get s
67b0: 65 72 76 65 72 20 69 6e 66 6f 20 66 72 6f 6d 20 erver info from
67c0: 22 6c 6f 67 66 22 2c 20 65 78 6e 3d 22 28 63 6f "logf", exn="(co
67d0: 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 ndition->list ex
67e0: 6e 29 29 0a 09 09 09 20 27 28 29 29 20 3b 3b 20 n)).... '()) ;;
67f0: 6e 6f 20 69 64 65 61 20 77 68 61 74 20 77 65 6e no idea what wen
6800: 74 20 77 72 6f 6e 67 2c 20 63 61 6c 6c 20 69 74 t wrong, call it
6810: 20 61 20 62 61 64 20 73 65 72 76 65 72 2c 20 72 a bad server, r
6820: 65 74 75 72 6e 20 65 6d 70 74 79 20 6c 69 73 74 eturn empty list
6830: 0a 09 09 20 20 20 20 20 20 20 28 77 69 74 68 2d ... (with-
6840: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
6850: 6c 6f 67 66 20 72 65 61 64 2d 6c 69 6e 65 73 29 logf read-lines)
6860: 29 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 ))). (if (
6870: 6e 75 6c 6c 3f 20 66 64 61 74 29 20 3b 3b 20 62 null? fdat) ;; b
6880: 61 64 20 64 61 74 61 2c 20 72 65 74 75 72 6e 20 ad data, return
6890: 62 61 64 2d 64 61 74 0a 09 20 20 20 62 61 64 2d bad-dat.. bad-
68a0: 64 61 74 0a 09 20 20 20 28 6c 65 74 20 6c 6f 6f dat.. (let loo
68b0: 70 20 28 28 69 6e 6c 20 20 28 63 61 72 20 66 64 p ((inl (car fd
68c0: 61 74 29 29 0a 09 09 20 20 20 20 20 20 28 74 61 at))... (ta
68d0: 69 6c 20 28 63 64 72 20 66 64 61 74 29 29 0a 09 il (cdr fdat))..
68e0: 09 20 20 20 20 20 20 28 6c 6e 75 6d 20 30 29 29 . (lnum 0))
68f0: 0a 09 20 20 20 20 20 28 6c 65 74 20 28 28 6d 6c .. (let ((ml
6900: 73 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 st (string-match
6910: 20 73 65 72 76 65 72 2d 72 78 20 69 6e 6c 29 29 server-rx inl))
6920: 0a 09 09 20 20 20 28 64 62 70 72 65 70 20 28 73 ... (dbprep (s
6930: 74 72 69 6e 67 2d 6d 61 74 63 68 20 64 62 70 72 tring-match dbpr
6940: 65 70 2d 72 78 20 69 6e 6c 29 29 29 0a 09 20 20 ep-rx inl)))..
6950: 20 20 20 20 20 28 69 66 20 64 62 70 72 65 70 20 (if dbprep
6960: 28 73 65 74 21 20 64 62 70 72 65 70 2d 66 6f 75 (set! dbprep-fou
6970: 6e 64 20 31 29 29 0a 09 20 20 20 20 20 20 20 28 nd 1)).. (
6980: 69 66 20 28 6e 6f 74 20 6d 6c 73 74 29 0a 09 09 if (not mlst)...
6990: 20 20 20 28 69 66 20 28 3e 20 6c 6e 75 6d 20 35 (if (> lnum 5
69a0: 30 30 29 20 3b 3b 20 67 69 76 65 20 75 70 20 69 00) ;; give up i
69b0: 66 20 6d 6f 72 65 20 74 68 61 6e 20 35 30 30 20 f more than 500
69c0: 6c 69 6e 65 73 20 6f 66 20 73 65 72 76 65 72 20 lines of server
69d0: 6c 6f 67 20 72 65 61 64 0a 09 09 20 20 20 20 20 log read...
69e0: 20 20 62 61 64 2d 64 61 74 0a 09 09 20 20 20 20 bad-dat...
69f0: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
6a00: 69 6c 29 0a 09 09 09 20 20 20 62 61 64 2d 64 61 il).... bad-da
6a10: 74 0a 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 63 t.... (loop (c
6a20: 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 61 69 ar tail)(cdr tai
6a30: 6c 29 28 2b 20 6c 6e 75 6d 20 31 29 29 29 29 0a l)(+ lnum 1)))).
6a40: 09 09 20 20 20 28 6d 61 74 63 68 20 6d 6c 73 74 .. (match mlst
6a50: 20 3b 3b 20 68 61 76 65 20 61 20 6e 6f 74 20 6e ;; have a not n
6a60: 75 6c 6c 20 6c 69 73 74 0a 09 09 20 20 20 20 20 ull list...
6a70: 28 28 5f 20 68 6f 73 74 20 70 6f 72 74 20 73 74 ((_ host port st
6a80: 61 72 74 20 73 65 72 76 65 72 2d 69 64 20 70 69 art server-id pi
6a90: 64 20 64 62 66 6e 61 6d 65 29 0a 09 09 20 20 20 d dbfname)...
6aa0: 20 20 20 28 6c 69 73 74 20 68 6f 73 74 0a 09 09 (list host...
6ab0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 . (string->nu
6ac0: 6d 62 65 72 20 70 6f 72 74 29 0a 09 09 09 20 20 mber port)....
6ad0: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
6ae0: 72 20 73 74 61 72 74 29 0a 09 09 09 20 20 20 20 r start)....
6af0: 73 65 72 76 65 72 2d 69 64 0a 09 09 09 20 20 20 server-id....
6b00: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
6b10: 20 70 69 64 29 0a 09 09 09 20 20 20 20 64 62 66 pid).... dbf
6b20: 6e 61 6d 65 0a 09 09 09 20 20 20 20 6c 6f 67 66 name.... logf
6b30: 29 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 0a ))... (else.
6b40: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
6b50: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
6b60: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
6b70: 3a 20 64 69 64 20 6e 6f 74 20 72 65 63 6f 67 6e : did not recogn
6b80: 69 73 65 20 53 45 52 56 45 52 20 6c 69 6e 65 20 ise SERVER line
6b90: 69 6e 66 6f 20 22 6d 6c 73 74 29 0a 09 09 20 20 info "mlst)...
6ba0: 20 20 20 20 62 61 64 2d 64 61 74 29 29 29 29 29 bad-dat)))))
6bb0: 29 29 29 29 0a 0a 3b 3b 20 47 69 76 65 6e 20 61 ))))..;; Given a
6bc0: 6e 20 61 72 65 61 20 70 61 74 68 2c 20 20 73 74 n area path, st
6bd0: 61 72 74 20 61 20 73 65 72 76 65 72 20 70 72 6f art a server pro
6be0: 63 65 73 73 20 20 20 20 23 23 23 20 4e 4f 54 45 cess ### NOTE
6bf0: 20 23 23 23 20 3e 20 66 69 6c 65 20 32 3e 26 31 ### > file 2>&1
6c00: 20 0a 3b 3b 20 69 66 20 74 68 65 20 74 61 72 67 .;; if the targ
6c10: 65 74 2d 68 6f 73 74 20 69 73 20 73 65 74 20 0a et-host is set .
6c20: 3b 3b 20 74 72 79 20 72 75 6e 6e 69 6e 67 20 6f ;; try running o
6c30: 6e 20 74 68 61 74 20 68 6f 73 74 0a 3b 3b 20 20 n that host.;;
6c40: 20 69 6e 63 69 64 65 6e 74 61 6c 3a 20 72 6f 74 incidental: rot
6c50: 61 74 65 20 6c 6f 67 73 20 69 6e 20 6c 6f 67 73 ate logs in logs
6c60: 2f 20 64 69 72 2e 0a 3b 3b 0a 28 64 65 66 69 6e / dir..;;.(defin
6c70: 65 20 20 28 74 74 3a 73 65 72 76 65 72 2d 70 72 e (tt:server-pr
6c80: 6f 63 65 73 73 2d 72 75 6e 20 61 72 65 61 70 61 ocess-run areapa
6c90: 74 68 20 74 65 73 74 73 75 69 74 65 20 6d 74 65 th testsuite mte
6ca0: 78 65 20 72 75 6e 2d 69 64 20 23 21 6b 65 79 20 xe run-id #!key
6cb0: 28 70 72 6f 66 69 6c 65 2d 6d 6f 64 65 20 22 22 (profile-mode ""
6cc0: 29 29 20 3b 3b 20 61 72 65 61 70 61 74 68 20 69 )) ;; areapath i
6cd0: 73 20 2a 74 6f 70 70 61 74 68 2a 20 66 6f 72 20 s *toppath* for
6ce0: 61 20 67 69 76 65 6e 20 74 65 73 74 73 75 69 74 a given testsuit
6cf0: 65 20 61 72 65 61 0a 20 20 28 61 73 73 65 72 74 e area. (assert
6d00: 20 61 72 65 61 70 61 74 68 20 20 22 46 41 54 41 areapath "FATA
6d10: 4c 3a 20 74 74 3a 73 65 72 76 65 72 2d 70 72 6f L: tt:server-pro
6d20: 63 65 73 73 2d 72 75 6e 20 63 61 6c 6c 65 64 20 cess-run called
6d30: 77 69 74 68 6f 75 74 20 61 72 65 61 70 61 74 68 without areapath
6d40: 20 64 65 66 69 6e 65 64 2e 22 29 0a 20 20 28 61 defined."). (a
6d50: 73 73 65 72 74 20 74 65 73 74 73 75 69 74 65 20 ssert testsuite
6d60: 22 46 41 54 41 4c 3a 20 74 74 3a 73 65 72 76 65 "FATAL: tt:serve
6d70: 72 2d 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 61 r-process-run ca
6d80: 6c 6c 65 64 20 77 69 74 68 6f 75 74 20 74 65 73 lled without tes
6d90: 74 73 75 69 74 65 20 64 65 66 69 6e 65 64 2e 22 tsuite defined."
6da0: 29 0a 20 20 28 61 73 73 65 72 74 20 6d 74 65 78 ). (assert mtex
6db0: 65 20 20 20 20 20 22 46 41 54 41 4c 3a 20 74 74 e "FATAL: tt
6dc0: 3a 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 2d :server-process-
6dd0: 72 75 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 6f run called witho
6de0: 75 74 20 6d 74 65 78 65 20 64 65 66 69 6e 65 64 ut mtexe defined
6df0: 2e 22 29 0a 20 20 3b 3b 20 6d 74 65 73 74 20 2d ."). ;; mtest -
6e00: 73 65 72 76 65 72 20 2d 20 2d 6d 20 74 65 73 74 server - -m test
6e10: 73 75 69 74 65 3a 65 78 74 2d 74 65 73 74 73 20 suite:ext-tests
6e20: 2d 64 62 20 36 2e 64 62 0a 20 20 28 6c 65 74 2a -db 6.db. (let*
6e30: 20 28 28 64 62 66 6e 61 6d 65 20 20 28 64 62 6d ((dbfname (dbm
6e40: 6f 64 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 6e 61 od:run-id->dbfna
6e50: 6d 65 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 6c me run-id)).. (l
6e60: 6f 61 64 20 20 20 20 20 28 67 65 74 2d 6e 6f 72 oad (get-nor
6e70: 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
6e80: 29 29 0a 09 20 28 6e 72 75 6e 20 20 20 20 20 28 )).. (nrun (
6e90: 6e 75 6d 62 65 72 2d 6f 66 2d 70 72 6f 63 65 73 number-of-proces
6ea0: 73 65 73 2d 72 75 6e 6e 69 6e 67 20 28 63 6f 6e ses-running (con
6eb0: 63 20 22 6d 74 65 73 74 2e 2a 73 65 72 76 65 72 c "mtest.*server
6ec0: 2e 2a 22 74 65 73 74 73 75 69 74 65 22 2e 2a 22 .*"testsuite".*"
6ed0: 64 62 66 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 dbfname)))).
6ee0: 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 3e 20 6c (cond. ((> l
6ef0: 6f 61 64 20 32 2e 30 29 0a 20 20 20 20 20 20 28 oad 2.0). (
6f00: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
6f10: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6f20: 20 22 4e 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 "Normalized loa
6f30: 64 20 22 6c 6f 61 64 22 20 6f 6e 20 22 20 28 67 d "load" on " (g
6f40: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 20 et-host-name) "
6f50: 69 73 20 6f 76 65 72 20 74 68 65 20 6c 69 6d 69 is over the limi
6f60: 74 20 6f 66 20 32 2e 30 2e 20 4e 6f 74 20 73 74 t of 2.0. Not st
6f70: 61 72 74 69 6e 67 20 61 20 73 65 72 76 65 72 2e arting a server.
6f80: 22 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 "). (thread
6f90: 2d 73 6c 65 65 70 21 20 31 29 29 0a 20 20 20 20 -sleep! 1)).
6fa0: 20 28 28 3e 20 6e 72 75 6e 20 31 30 30 29 0a 20 ((> nrun 100).
6fb0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6fc0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
6fd0: 2d 70 6f 72 74 2a 20 6e 72 75 6e 22 20 73 65 72 -port* nrun" ser
6fe0: 76 65 72 73 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 vers running on
6ff0: 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 " (get-host-name
7000: 29 20 22 2c 20 6e 6f 74 20 73 74 61 72 74 69 6e ) ", not startin
7010: 67 20 61 6e 6f 74 68 65 72 2e 22 29 0a 20 20 20 g another.").
7020: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
7030: 21 20 31 29 29 0a 20 20 20 20 20 28 65 6c 73 65 ! 1)). (else
7040: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
7050: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 (file-exists? (c
7060: 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f 6c 6f onc areapath"/lo
7070: 67 73 22 29 29 29 0a 09 20 20 20 20 20 20 28 63 gs"))).. (c
7080: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
7090: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f (conc areapath"/
70a0: 6c 6f 67 73 22 29 20 23 74 29 29 0a 09 20 20 28 logs") #t)).. (
70b0: 6c 65 74 2a 20 28 28 6c 6f 67 66 69 6c 65 20 20 let* ((logfile
70c0: 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 (conc areapath
70d0: 22 2f 6c 6f 67 73 2f 73 65 72 76 65 72 2d 22 64 "/logs/server-"d
70e0: 62 66 6e 61 6d 65 22 2d 22 28 63 75 72 72 65 6e bfname"-"(curren
70f0: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 2e 6c t-process-id)".l
7100: 6f 67 22 29 29 20 3b 3b 20 2d 22 20 63 75 72 72 og")) ;; -" curr
7110: 2d 70 69 64 20 22 2d 22 20 74 61 72 67 65 74 2d -pid "-" target-
7120: 68 6f 73 74 20 22 2e 6c 6f 67 22 29 29 0a 09 09 host ".log"))...
7130: 20 28 63 6d 64 6c 6e 20 20 20 20 20 28 63 6f 6e (cmdln (con
7140: 63 0a 09 09 09 20 20 20 20 20 6d 74 65 78 65 0a c.... mtexe.
7150: 09 09 09 20 20 20 20 20 22 20 2d 73 65 72 76 65 ... " -serve
7160: 72 20 2d 20 22 3b 3b 20 28 6f 72 20 74 61 72 67 r - ";; (or targ
7170: 65 74 2d 68 6f 73 74 20 22 2d 22 29 0a 09 09 09 et-host "-")....
7180: 20 20 20 20 20 22 20 2d 6d 20 74 65 73 74 73 75 " -m testsu
7190: 69 74 65 3a 22 20 74 65 73 74 73 75 69 74 65 0a ite:" testsuite.
71a0: 09 09 09 20 20 20 20 20 3b 3b 20 22 20 2d 72 75 ... ;; " -ru
71b0: 6e 2d 69 64 20 22 20 28 6f 72 20 72 75 6e 2d 69 n-id " (or run-i
71c0: 64 20 22 6d 61 69 6e 22 29 20 3b 3b 20 4e 4f 2c d "main") ;; NO,
71d0: 20 77 65 20 64 6f 20 4e 4f 54 20 77 61 6e 74 20 we do NOT want
71e0: 74 6f 20 68 61 76 65 20 72 75 6e 20 69 64 20 61 to have run id a
71f0: 73 20 70 61 72 74 20 6f 66 20 74 68 69 73 0a 09 s part of this..
7200: 09 09 20 20 20 20 20 22 20 2d 64 62 20 22 20 20 .. " -db "
7210: 64 62 66 6e 61 6d 65 20 3b 3b 20 28 64 62 6d 6f dbfname ;; (dbmo
7220: 64 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 6e 61 6d d:run-id->dbfnam
7230: 65 20 72 75 6e 2d 69 64 29 0a 09 09 09 20 20 20 e run-id)....
7240: 20 20 22 20 22 20 70 72 6f 66 69 6c 65 2d 6d 6f " " profile-mo
7250: 64 65 0a 09 09 09 20 20 20 20 20 29 29 29 20 3b de.... ))) ;
7260: 3b 20 28 63 6f 6e 63 20 22 20 3e 3e 20 22 20 6c ; (conc " >> " l
7270: 6f 67 66 69 6c 65 20 22 20 32 3e 26 31 20 26 22 ogfile " 2>&1 &"
7280: 29 29 29 29 29 0a 09 20 20 20 20 3b 3b 20 77 65 ))))).. ;; we
7290: 20 77 61 6e 74 20 74 68 65 20 72 65 6d 6f 74 65 want the remote
72a0: 20 73 65 72 76 65 72 20 74 6f 20 73 74 61 72 74 server to start
72b0: 20 69 6e 20 2a 74 6f 70 70 61 74 68 2a 20 73 6f in *toppath* so
72c0: 20 70 75 73 68 20 74 68 65 72 65 0a 09 20 20 20 push there..
72d0: 20 3b 3b 20 28 70 75 73 68 2d 64 69 72 65 63 74 ;; (push-direct
72e0: 6f 72 79 20 61 72 65 61 70 61 74 68 29 20 3b 3b ory areapath) ;;
72f0: 20 75 73 65 20 63 64 20 69 6e 20 74 68 65 20 63 use cd in the c
7300: 6f 6d 6d 61 6e 64 20 6c 69 6e 65 20 69 6e 73 74 ommand line inst
7310: 65 61 64 0a 09 20 20 20 20 28 64 65 62 75 67 3a ead.. (debug:
7320: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
7330: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
7340: 3a 20 54 72 79 69 6e 67 20 74 6f 20 73 74 61 72 : Trying to star
7350: 74 20 73 65 72 76 65 72 20 69 6e 20 74 63 70 20 t server in tcp
7360: 6d 6f 64 65 20 28 22 20 63 6d 64 6c 6e 20 22 29 mode (" cmdln ")
7370: 20 61 74 20 22 28 63 6f 6d 6d 6f 6e 3a 68 75 6d at "(common:hum
7380: 61 6e 2d 74 69 6d 65 29 22 20 66 6f 72 20 22 61 an-time)" for "a
7390: 72 65 61 70 61 74 68 29 0a 09 20 20 20 20 3b 3b reapath).. ;;
73a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
73b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
73c0: 74 2a 20 22 49 4e 46 4f 3a 20 73 74 61 72 74 69 t* "INFO: starti
73d0: 6e 67 20 73 65 72 76 65 72 20 61 74 20 22 20 28 ng server at " (
73e0: 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d common:human-tim
73f0: 65 29 29 0a 09 20 20 20 20 28 73 65 74 65 6e 76 e)).. (setenv
7400: 20 22 4e 42 46 41 4b 45 5f 51 55 49 45 54 22 20 "NBFAKE_QUIET"
7410: 22 79 65 73 22 29 20 3b 3b 20 42 55 47 3a 20 63 "yes") ;; BUG: c
7420: 68 61 6e 67 65 20 74 6f 20 77 69 74 68 2d 65 6e hange to with-en
7430: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
7440: 6c 65 20 2e 2e 2e 0a 09 20 20 20 20 28 73 65 74 le ..... (set
7450: 65 6e 76 20 22 4e 42 46 41 4b 45 5f 4c 4f 47 22 env "NBFAKE_LOG"
7460: 20 6c 6f 67 66 69 6c 65 29 0a 09 20 20 20 20 28 logfile).. (
7470: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 63 64 system (conc "cd
7480: 20 22 61 72 65 61 70 61 74 68 22 20 3b 20 6e 62 "areapath" ; nb
7490: 66 61 6b 65 20 22 20 63 6d 64 6c 6e 29 29 0a 09 fake " cmdln))..
74a0: 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 4e (unsetenv "N
74b0: 42 46 41 4b 45 5f 51 55 49 45 54 22 29 0a 09 20 BFAKE_QUIET")..
74c0: 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 4e 42 (unsetenv "NB
74d0: 46 41 4b 45 5f 4c 4f 47 22 29 0a 09 20 20 20 20 FAKE_LOG")..
74e0: 3b 3b 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 79 ;;(pop-directory
74f0: 29 0a 09 20 20 20 20 29 29 29 29 29 0a 0a 3b 3b ).. )))))..;;
7500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7540: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 63 70 20 63 6f ======.;; tcp co
7550: 6e 6e 65 63 74 69 6f 6e 20 73 74 75 66 66 0a 3b nnection stuff.;
7560: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75a0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 6e 64 =======..;; find
75b0: 20 61 20 70 6f 72 74 20 61 6e 64 20 73 74 61 72 a port and star
75c0: 74 20 74 63 70 2d 73 65 72 76 65 72 2e 20 54 68 t tcp-server. Th
75d0: 69 73 20 6f 6e 6c 79 20 73 74 61 72 74 73 20 74 is only starts t
75e0: 68 65 20 74 63 70 20 70 6f 72 74 69 6f 6e 20 6f he tcp portion o
75f0: 66 0a 3b 3b 20 74 68 65 20 73 65 72 76 65 72 2c f.;; the server,
7600: 20 6c 6f 6f 6b 20 61 74 20 28 74 74 3a 73 74 61 look at (tt:sta
7610: 72 74 2d 73 65 72 76 65 72 20 2e 2e 2e 29 20 61 rt-server ...) a
7620: 62 6f 76 65 20 66 6f 72 20 74 68 65 20 65 6e 74 bove for the ent
7630: 72 79 20 70 6f 69 6e 74 0a 3b 3b 20 66 6f 72 20 ry point.;; for
7640: 74 68 65 20 65 6e 74 69 72 65 20 73 65 72 76 65 the entire serve
7650: 72 20 73 79 73 74 65 6d 0a 3b 3b 0a 28 64 65 66 r system.;;.(def
7660: 69 6e 65 20 28 74 74 3a 73 74 61 72 74 2d 74 63 ine (tt:start-tc
7670: 70 2d 73 65 72 76 65 72 20 74 74 64 61 74 29 0a p-server ttdat).
7680: 20 20 28 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 (setup-listene
7690: 72 2d 70 6f 72 74 6c 6f 67 67 65 72 20 74 74 64 r-portlogger ttd
76a0: 61 74 29 20 3b 3b 20 73 65 74 20 75 70 20 74 63 at) ;; set up tc
76b0: 70 2d 6c 69 73 74 65 6e 65 72 0a 20 20 28 6c 65 p-listener. (le
76c0: 74 2a 20 28 28 73 6f 63 6b 65 74 20 20 20 28 74 t* ((socket (t
76d0: 74 2d 73 6f 63 6b 65 74 20 20 74 74 64 61 74 29 t-socket ttdat)
76e0: 29 0a 09 20 28 68 61 6e 64 6c 65 72 20 20 28 74 ).. (handler (t
76f0: 74 2d 68 61 6e 64 6c 65 72 20 74 74 64 61 74 29 t-handler ttdat)
7700: 29 20 3b 3b 20 74 68 65 20 68 61 6e 64 6c 65 72 ) ;; the handler
7710: 20 63 6f 6d 65 73 20 66 72 6f 6d 20 6f 75 72 20 comes from our
7720: 63 6c 69 65 6e 74 20 73 65 74 74 69 6e 67 20 61 client setting a
7730: 20 68 61 6e 64 6c 65 72 20 66 75 6e 63 74 69 6f handler functio
7740: 6e 0a 09 20 28 68 61 6e 64 6c 65 72 2d 70 72 6f n.. (handler-pro
7750: 63 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 c (lambda ()....
7760: 20 28 6c 65 74 2a 20 28 28 69 6e 64 61 74 20 20 (let* ((indat
7770: 20 20 20 20 20 20 20 28 64 65 73 65 72 69 61 6c (deserial
7780: 69 7a 65 29 29 0a 09 09 09 09 28 72 65 73 75 6c ize)).....(resul
7790: 74 20 20 20 20 20 20 20 20 23 66 29 0a 09 09 09 t #f)....
77a0: 09 28 65 78 6e 2d 72 65 73 75 6c 74 20 20 20 20 .(exn-result
77b0: 23 66 29 0a 09 09 09 09 28 73 74 64 6f 75 74 2d #f).....(stdout-
77c0: 72 65 73 75 6c 74 20 28 77 69 74 68 2d 6f 75 74 result (with-out
77d0: 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 09 09 put-to-string...
77e0: 09 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a .... (lambda ().
77f0: 09 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 ...... (let ((
7800: 72 65 73 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 res (handle-exce
7810: 70 74 69 6f 6e 73 0a 09 09 09 09 09 09 09 09 20 ptions.........
7820: 20 65 78 6e 0a 09 09 09 09 09 09 09 09 28 6c 65 exn.........(le
7830: 74 2a 20 28 28 65 72 72 64 61 74 20 28 63 6f 6e t* ((errdat (con
7840: 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e dition->list exn
7850: 29 29 29 0a 09 09 09 09 09 09 09 09 20 20 28 73 )))......... (s
7860: 65 74 21 20 65 78 6e 2d 72 65 73 75 6c 74 20 65 et! exn-result e
7870: 72 72 64 61 74 29 0a 09 09 09 09 09 09 09 09 20 rrdat).........
7880: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
7890: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
78a0: 74 2a 20 22 45 52 52 4f 52 3a 20 68 61 6e 64 6c t* "ERROR: handl
78b0: 65 72 20 65 78 63 65 70 74 69 6f 6e 2c 20 74 68 er exception, th
78c0: 65 73 65 20 61 72 65 20 62 61 64 2c 20 77 69 6c ese are bad, wil
78d0: 6c 20 65 78 69 74 20 69 6e 20 66 69 76 65 20 73 l exit in five s
78e0: 65 63 6f 6e 64 73 2e 22 29 0a 09 09 09 09 09 09 econds.").......
78f0: 09 09 20 20 28 70 70 20 65 72 72 64 61 74 20 2a .. (pp errdat *
7900: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7910: 2a 29 0a 09 09 09 09 09 09 09 09 20 20 3b 3b 20 *)......... ;;
7920: 74 68 65 73 65 20 61 72 65 20 61 6c 77 61 79 73 these are always
7930: 20 62 61 64 2c 20 73 65 74 20 75 70 20 61 6e 20 bad, set up an
7940: 65 78 69 74 20 74 68 72 65 61 64 0a 09 09 09 09 exit thread.....
7950: 09 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 74 .... (thread-st
7960: 61 72 74 21 20 28 6d 61 6b 65 2d 74 68 72 65 61 art! (make-threa
7970: 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 d (lambda ()....
7980: 09 09 09 09 09 09 09 09 09 28 74 68 72 65 61 64 .........(thread
7990: 2d 73 6c 65 65 70 21 20 35 29 0a 09 09 09 09 09 -sleep! 5)......
79a0: 09 09 09 09 09 09 09 28 65 78 69 74 29 29 29 29 .......(exit))))
79b0: 0a 09 09 09 09 09 09 09 09 20 20 23 66 29 0a 09 ......... #f)..
79c0: 09 09 09 09 09 09 09 28 68 61 6e 64 6c 65 72 20 .......(handler
79d0: 69 6e 64 61 74 29 20 3b 3b 20 74 68 69 73 20 69 indat) ;; this i
79e0: 73 20 74 68 65 20 70 72 6f 63 20 62 65 69 6e 67 s the proc being
79f0: 20 63 61 6c 6c 65 64 20 62 79 20 74 68 65 20 72 called by the r
7a00: 65 6d 6f 74 65 20 63 6c 69 65 6e 74 0a 09 09 09 emote client....
7a10: 09 09 09 09 09 29 29 29 0a 09 09 09 09 09 09 20 .....))).......
7a20: 20 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 (set! result
7a30: 20 72 65 73 29 29 29 29 29 0a 09 09 09 09 28 66 res))))).....(f
7a40: 75 6c 6c 2d 72 65 73 75 6c 74 20 28 6c 69 73 74 ull-result (list
7a50: 20 72 65 73 75 6c 74 20 65 78 6e 2d 72 65 73 75 result exn-resu
7a60: 6c 74 20 28 69 66 20 28 65 71 75 61 6c 3f 20 73 lt (if (equal? s
7a70: 74 64 6f 75 74 2d 72 65 73 75 6c 74 20 22 22 29 tdout-result "")
7a80: 20 23 66 20 73 74 64 6f 75 74 2d 72 65 73 75 6c #f stdout-resul
7a90: 74 29 29 29 29 0a 09 09 09 20 20 20 28 68 61 6e t)))).... (han
7aa0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
7ab0: 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 09 09 .. exn....
7ac0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 (begin....
7ad0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7ae0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
7af0: 67 2d 70 6f 72 74 2a 20 22 53 65 72 69 61 6c 69 g-port* "Seriali
7b00: 7a 61 74 69 6f 6e 20 66 61 69 6c 75 72 65 2e 20 zation failure.
7b10: 66 75 6c 6c 2d 72 65 73 75 6c 74 3d 22 66 75 6c full-result="ful
7b20: 6c 2d 72 65 73 75 6c 74 29 0a 09 09 09 20 20 20 l-result)....
7b30: 20 20 20 20 3b 3b 20 28 73 65 72 69 61 6c 69 7a ;; (serializ
7b40: 65 20 27 28 23 66 20 23 66 20 23 66 29 29 20 3b e '(#f #f #f)) ;
7b50: 3b 20 64 6f 65 73 6e 27 74 20 77 6f 72 6b 20 2d ; doesn't work -
7b60: 20 74 68 65 20 66 69 72 73 74 20 63 61 6c 6c 20 the first call
7b70: 74 6f 20 73 65 72 69 61 6c 69 7a 65 20 63 61 75 to serialize cau
7b80: 73 65 64 20 66 61 69 6c 75 72 65 0a 09 09 09 20 sed failure....
7b90: 20 20 20 20 20 20 29 0a 09 09 09 20 20 20 20 20 )....
7ba0: 28 73 65 72 69 61 6c 69 7a 65 20 66 75 6c 6c 2d (serialize full-
7bb0: 72 65 73 75 6c 74 29 29 29 29 29 29 0a 20 20 20 result)))))).
7bc0: 20 28 28 6d 61 6b 65 2d 74 63 70 2d 73 65 72 76 ((make-tcp-serv
7bd0: 65 72 20 73 6f 63 6b 65 74 20 68 61 6e 64 6c 65 er socket handle
7be0: 72 2d 70 72 6f 63 29 0a 20 20 20 20 20 23 66 20 r-proc). #f
7bf0: 3b 3b 20 79 65 73 2c 20 73 65 6e 64 20 65 72 72 ;; yes, send err
7c00: 6f 72 20 6d 65 73 73 61 67 65 73 20 74 6f 20 73 or messages to s
7c10: 74 64 2d 65 72 72 0a 20 20 20 20 20 29 29 29 0a td-err. ))).
7c20: 0a 3b 3b 20 63 72 65 61 74 65 20 61 20 74 63 70 .;; create a tcp
7c30: 20 6c 69 73 74 65 6e 65 72 20 61 6e 64 20 72 65 listener and re
7c40: 74 75 72 6e 20 61 20 70 6f 70 75 6c 61 74 65 64 turn a populated
7c50: 20 75 64 61 74 20 73 74 72 75 63 74 20 77 69 74 udat struct wit
7c60: 68 0a 3b 3b 20 6d 79 20 70 6f 72 74 2c 20 61 64 h.;; my port, ad
7c70: 64 72 65 73 73 2c 20 68 6f 73 74 6e 61 6d 65 2c dress, hostname,
7c80: 20 70 69 64 20 65 74 63 2e 0a 3b 3b 20 72 65 74 pid etc..;; ret
7c90: 75 72 6e 20 23 66 20 69 66 20 66 61 69 6c 20 74 urn #f if fail t
7ca0: 6f 20 66 69 6e 64 20 61 20 70 6f 72 74 20 74 6f o find a port to
7cb0: 20 61 6c 6c 6f 63 61 74 65 2e 0a 3b 3b 0a 3b 3b allocate..;;.;;
7cc0: 20 20 69 66 20 75 64 61 74 61 2d 69 6e 20 69 73 if udata-in is
7cd0: 20 23 66 20 63 72 65 61 74 65 20 74 68 65 20 72 #f create the r
7ce0: 65 63 6f 72 64 0a 3b 3b 20 20 69 66 20 74 68 65 ecord.;; if the
7cf0: 72 65 20 69 73 20 61 6c 72 65 61 64 79 20 61 20 re is already a
7d00: 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 72 65 serv-listener re
7d10: 74 75 72 6e 20 74 68 65 20 75 64 61 74 61 0a 3b turn the udata.;
7d20: 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 ;.;; (define (se
7d30: 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f tup-listener uco
7d40: 6e 6e 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 70 nn #!optional (p
7d50: 6f 72 74 20 34 32 34 32 29 29 0a 3b 3b 20 20 20 ort 4242)).;;
7d60: 28 61 73 73 65 72 74 20 28 74 74 3f 20 75 63 6f (assert (tt? uco
7d70: 6e 6e 29 20 22 46 41 54 41 4c 3a 20 73 65 74 75 nn) "FATAL: setu
7d80: 70 2d 6c 69 73 74 65 6e 65 72 20 63 61 6c 6c 65 p-listener calle
7d90: 64 20 77 69 74 68 20 77 72 6f 6e 67 20 73 74 72 d with wrong str
7da0: 75 63 74 20 22 75 63 6f 6e 6e 29 0a 3b 3b 20 20 uct "uconn).;;
7db0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
7dc0: 6f 6e 73 0a 3b 3b 20 20 20 20 65 78 6e 0a 3b 3b ons.;; exn.;;
7dd0: 20 20 20 20 28 69 66 20 28 3c 20 70 6f 72 74 20 (if (< port
7de0: 36 35 35 33 35 29 0a 3b 3b 20 20 20 20 20 20 20 65535).;;
7df0: 20 28 62 65 67 69 6e 0a 3b 3b 20 09 20 28 74 68 (begin.;; . (th
7e00: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 read-sleep! 0.25
7e10: 29 0a 3b 3b 20 09 20 28 73 65 74 75 70 2d 6c 69 ).;; . (setup-li
7e20: 73 74 65 6e 65 72 20 75 63 6f 6e 6e 20 28 2b 20 stener uconn (+
7e30: 70 6f 72 74 20 31 29 29 29 0a 3b 3b 20 20 20 20 port 1))).;;
7e40: 20 20 20 20 23 66 29 0a 3b 3b 20 20 20 20 28 63 #f).;; (c
7e50: 6f 6e 6e 65 63 74 2d 6c 69 73 74 65 6e 65 72 20 onnect-listener
7e60: 75 63 6f 6e 6e 20 70 6f 72 74 29 29 29 0a 0a 28 uconn port)))..(
7e70: 64 65 66 69 6e 65 20 28 73 65 74 75 70 2d 6c 69 define (setup-li
7e80: 73 74 65 6e 65 72 2d 70 6f 72 74 6c 6f 67 67 65 stener-portlogge
7e90: 72 20 75 63 6f 6e 6e 29 0a 20 20 28 6c 65 74 20 r uconn). (let
7ea0: 28 28 70 6f 72 74 20 28 70 6f 72 74 6c 6f 67 67 ((port (portlogg
7eb0: 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 er:open-run-clos
7ec0: 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 6e e portlogger:fin
7ed0: 64 2d 70 6f 72 74 29 29 29 0a 20 20 20 20 28 61 d-port))). (a
7ee0: 73 73 65 72 74 20 28 74 74 3f 20 75 63 6f 6e 6e ssert (tt? uconn
7ef0: 29 20 22 46 41 54 41 4c 3a 20 73 65 74 75 70 2d ) "FATAL: setup-
7f00: 6c 69 73 74 65 6e 65 72 20 63 61 6c 6c 65 64 20 listener called
7f10: 77 69 74 68 20 77 72 6f 6e 67 20 73 74 72 75 63 with wrong struc
7f20: 74 20 22 75 63 6f 6e 6e 29 0a 20 20 20 20 28 68 t "uconn). (h
7f30: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
7f40: 0a 09 65 78 6e 0a 20 20 20 20 20 20 28 69 66 20 ..exn. (if
7f50: 28 3c 20 70 6f 72 74 20 36 35 35 33 35 29 0a 09 (< port 65535)..
7f60: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 70 (begin.. (p
7f70: 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 ortlogger:open-r
7f80: 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 un-close portlog
7f90: 67 65 72 3a 73 65 74 2d 66 61 69 6c 65 64 20 70 ger:set-failed p
7fa0: 6f 72 74 29 0a 09 20 20 20 20 28 74 68 72 65 61 ort).. (threa
7fb0: 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 d-sleep! 0.25)..
7fc0: 20 20 20 20 28 73 65 74 75 70 2d 6c 69 73 74 65 (setup-liste
7fd0: 6e 65 72 2d 70 6f 72 74 6c 6f 67 67 65 72 20 75 ner-portlogger u
7fe0: 63 6f 6e 6e 29 29 0a 09 20 20 23 66 29 0a 20 20 conn)).. #f).
7ff0: 20 20 20 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 (connect-lis
8000: 74 65 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 tener uconn port
8010: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
8020: 6f 6e 6e 65 63 74 2d 6c 69 73 74 65 6e 65 72 20 onnect-listener
8030: 75 63 6f 6e 6e 20 70 6f 72 74 29 0a 20 20 3b 3b uconn port). ;;
8040: 20 28 74 63 70 2d 6c 69 73 74 65 6e 65 72 2d 73 (tcp-listener-s
8050: 6f 63 6b 65 74 20 4c 49 53 54 45 4e 45 52 29 28 ocket LISTENER)(
8060: 73 6f 63 6b 65 74 2d 6e 61 6d 65 20 73 6f 29 0a socket-name so).
8070: 20 20 3b 3b 20 73 6f 63 6b 61 64 64 72 2d 61 64 ;; sockaddr-ad
8080: 64 72 65 73 73 2c 20 73 6f 63 6b 61 64 64 72 2d dress, sockaddr-
8090: 70 6f 72 74 2c 20 73 6f 63 6b 61 64 64 72 2d 3e port, sockaddr->
80a0: 73 74 72 69 6e 67 0a 20 20 28 6c 65 74 2a 20 28 string. (let* (
80b0: 28 74 6c 73 6e 20 28 74 63 70 2d 6c 69 73 74 65 (tlsn (tcp-liste
80c0: 6e 20 70 6f 72 74 20 31 30 30 30 30 20 23 66 29 n port 10000 #f)
80d0: 29 20 3b 3b 20 28 74 63 70 2d 6c 69 73 74 65 6e ) ;; (tcp-listen
80e0: 20 54 43 50 50 4f 52 54 20 5b 42 41 43 4b 4c 4f TCPPORT [BACKLO
80f0: 47 20 5b 48 4f 53 54 5d 5d 29 0a 09 20 28 61 64 G [HOST]]).. (ad
8100: 64 72 20 20 28 74 74 3a 67 65 74 2d 62 65 73 74 dr (tt:get-best
8110: 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 28 -guess-address (
8120: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 get-host-name)))
8130: 29 20 3b 3b 20 28 67 65 74 2d 6d 79 2d 62 65 73 ) ;; (get-my-bes
8140: 74 2d 61 64 64 72 65 73 73 29 29 29 20 3b 3b 20 t-address))) ;;
8150: 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 (hostinfo-addres
8160: 73 65 73 20 28 68 6f 73 74 2d 69 6e 66 6f 72 6d ses (host-inform
8170: 61 74 69 6f 6e 20 28 63 75 72 72 65 6e 74 2d 68 ation (current-h
8180: 6f 73 74 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 ostname))). (
8190: 74 74 2d 70 6f 72 74 2d 73 65 74 21 20 20 20 20 tt-port-set!
81a0: 20 20 75 63 6f 6e 6e 20 70 6f 72 74 29 0a 20 20 uconn port).
81b0: 20 20 28 74 74 2d 68 6f 73 74 2d 73 65 74 21 20 (tt-host-set!
81c0: 20 20 20 20 20 75 63 6f 6e 6e 20 61 64 64 72 29 uconn addr)
81d0: 0a 20 20 20 20 28 74 74 2d 68 6f 73 74 2d 70 6f . (tt-host-po
81e0: 72 74 2d 73 65 74 21 20 75 63 6f 6e 6e 20 28 63 rt-set! uconn (c
81f0: 6f 6e 63 20 61 64 64 72 22 3a 22 70 6f 72 74 29 onc addr":"port)
8200: 29 0a 20 20 20 20 28 74 74 2d 73 6f 63 6b 65 74 ). (tt-socket
8210: 2d 73 65 74 21 20 20 20 20 75 63 6f 6e 6e 20 74 -set! uconn t
8220: 6c 73 6e 29 0a 20 20 20 20 75 63 6f 6e 6e 29 29 lsn). uconn))
8230: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
8240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 75 74 ==========.;; ut
8280: 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ils.;;==========
8290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
82d0: 20 47 65 6e 65 72 61 74 65 20 61 20 75 6e 69 71 Generate a uniq
82e0: 75 65 20 73 69 67 6e 61 74 75 72 65 20 66 6f 72 ue signature for
82f0: 20 74 68 69 73 20 73 65 72 76 65 72 0a 28 64 65 this server.(de
8300: 66 69 6e 65 20 28 74 74 3a 6d 6b 2d 73 69 67 6e fine (tt:mk-sign
8310: 61 74 75 72 65 20 61 72 65 61 70 61 74 68 29 0a ature areapath).
8320: 20 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 (message-diges
8330: 74 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 t-string (md5-pr
8340: 69 6d 69 74 69 76 65 29 20 0a 09 09 09 20 28 77 imitive) .... (w
8350: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 ith-output-to-st
8360: 72 69 6e 67 0a 09 09 09 20 20 20 28 6c 61 6d 62 ring.... (lamb
8370: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 77 da ().... (w
8380: 72 69 74 65 20 28 6c 69 73 74 20 61 72 65 61 70 rite (list areap
8390: 61 74 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 ath.
83a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
83c0: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
83d0: 64 29 0a 09 09 09 09 09 20 20 28 61 72 67 76 29 d)...... (argv)
83e0: 29 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 ))))))...(define
83f0: 20 28 74 74 3a 67 65 74 2d 62 65 73 74 2d 67 75 (tt:get-best-gu
8400: 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 ess-address host
8410: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 name). (let ((r
8420: 65 73 20 23 66 29 29 0a 20 20 20 20 28 66 6f 72 es #f)). (for
8430: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
8440: 62 64 61 20 28 61 64 72 29 0a 20 20 20 20 20 20 bda (adr).
8450: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 (if (not (eq? (
8460: 75 38 76 65 63 74 6f 72 2d 72 65 66 20 61 64 72 u8vector-ref adr
8470: 20 30 29 20 31 32 37 29 29 0a 09 20 20 20 28 73 0) 127)).. (s
8480: 65 74 21 20 72 65 73 20 61 64 72 29 29 29 0a 20 et! res adr))).
8490: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
84a0: 73 20 63 61 6e 20 66 61 69 6c 20 77 68 65 6e 20 s can fail when
84b0: 74 68 65 72 65 20 69 73 20 6e 6f 20 6d 65 6e 74 there is no ment
84c0: 69 6f 6e 20 6f 66 20 74 68 65 20 68 6f 73 74 20 ion of the host
84d0: 69 6e 20 2f 65 74 63 2f 68 6f 73 74 73 2e 20 46 in /etc/hosts. F
84e0: 49 58 4d 45 0a 20 20 20 20 20 28 76 65 63 74 6f IXME. (vecto
84f0: 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 69 6e 66 r->list (hostinf
8500: 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 o-addresses (hos
8510: 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 tname->hostinfo
8520: 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 20 hostname)))).
8530: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
8540: 65 72 73 65 20 0a 20 20 20 20 20 28 6d 61 70 20 erse . (map
8550: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 0a 09 number->string..
8560: 20 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 (u8vector->lis
8570: 74 0a 09 20 20 20 28 69 66 20 72 65 73 20 72 65 t.. (if res re
8580: 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 s (hostname->ip
8590: 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 22 2e 22 hostname)))) "."
85a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 )))..(define (tt
85b0: 3a 67 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 :get-servinfo-di
85c0: 72 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 6c r areapath). (l
85d0: 65 74 2a 20 28 28 73 70 61 74 68 20 28 63 6f 6e et* ((spath (con
85e0: 63 20 61 72 65 61 70 61 74 68 22 2f 2e 73 65 72 c areapath"/.ser
85f0: 76 69 6e 66 6f 22 29 29 29 0a 20 20 20 20 28 69 vinfo"))). (i
8600: 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 f (not (file-exi
8610: 73 74 73 3f 20 73 70 61 74 68 29 29 0a 09 28 63 sts? spath))..(c
8620: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
8630: 73 70 61 74 68 20 23 74 29 29 0a 20 20 20 20 73 spath #t)). s
8640: 70 61 74 68 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d path))..;;======
8650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8690: 0a 3b 3b 20 6e 65 74 77 6f 72 6b 20 75 74 69 6c .;; network util
86a0: 69 74 69 65 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ities.;;========
86b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
86f0: 3b 3b 20 4e 4f 54 45 3a 20 4c 6f 6f 6b 20 61 74 ;; NOTE: Look at
8700: 20 61 64 64 72 65 73 73 2d 69 6e 66 6f 20 65 67 address-info eg
8710: 67 20 61 73 20 61 6c 74 65 72 6e 61 74 69 76 65 g as alternative
8720: 20 74 6f 20 73 6f 6d 65 20 6f 66 20 74 68 69 73 to some of this
8730: 0a 0a 28 64 65 66 69 6e 65 20 28 72 61 74 65 2d ..(define (rate-
8740: 69 70 20 69 70 61 64 64 72 29 0a 20 20 28 72 65 ip ipaddr). (re
8750: 67 65 78 2d 63 61 73 65 20 69 70 61 64 64 72 0a gex-case ipaddr.
8760: 20 20 20 20 28 20 22 5e 31 32 37 5c 5c 2e 2e 2a ( "^127\\..*
8770: 22 20 5f 20 30 20 29 0a 20 20 20 20 28 20 22 5e " _ 0 ). ( "^
8780: 28 31 30 5c 5c 2e 30 7c 31 39 32 5c 5c 2e 31 36 (10\\.0|192\\.16
8790: 38 29 5c 5c 2e 2e 2a 22 20 5f 20 31 20 29 0a 20 8)\\..*" _ 1 ).
87a0: 20 20 20 28 20 65 6c 73 65 20 32 20 29 20 29 29 ( else 2 ) ))
87b0: 0a 0a 3b 3b 20 43 68 61 6e 67 65 20 74 68 69 73 ..;; Change this
87c0: 20 74 6f 20 62 69 61 73 20 66 6f 72 20 61 64 64 to bias for add
87d0: 72 65 73 73 65 73 20 77 69 74 68 20 61 20 72 65 resses with a re
87e0: 61 73 6f 6e 61 62 6c 65 20 62 72 6f 61 64 63 61 asonable broadca
87f0: 73 74 20 76 61 6c 75 65 3f 0a 3b 3b 0a 28 64 65 st value?.;;.(de
8800: 66 69 6e 65 20 28 69 70 2d 70 72 65 66 2d 6c 65 fine (ip-pref-le
8810: 73 73 3f 20 61 20 62 29 0a 20 20 28 3e 20 28 72 ss? a b). (> (r
8820: 61 74 65 2d 69 70 20 61 29 20 28 72 61 74 65 2d ate-ip a) (rate-
8830: 69 70 20 62 29 29 29 0a 0a 28 64 65 66 69 6e 65 ip b)))..(define
8840: 20 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 (get-my-best-ad
8850: 64 72 65 73 73 29 0a 20 20 28 6c 65 74 20 28 28 dress). (let ((
8860: 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 all-my-addresses
8870: 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 29 29 (get-all-ips)))
8880: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
8890: 28 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 ((null? all-my-a
88a0: 64 64 72 65 73 73 65 73 29 0a 20 20 20 20 20 20 ddresses).
88b0: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
88c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88e0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 ;; no
88f0: 69 6e 74 65 72 66 61 63 65 73 3f 0a 20 20 20 20 interfaces?.
8900: 20 28 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 61 ((eq? (length a
8910: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 ll-my-addresses)
8920: 20 31 29 0a 20 20 20 20 20 20 28 63 61 72 20 61 1). (car a
8930: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 ll-my-addresses)
8940: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
8950: 20 20 20 20 20 20 20 3b 3b 20 6f 6e 6c 79 20 6f ;; only o
8960: 6e 65 20 74 6f 20 63 68 6f 6f 73 65 20 66 72 6f ne to choose fro
8970: 6d 2c 20 6a 75 73 74 20 67 6f 20 77 69 74 68 20 m, just go with
8980: 69 74 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 it. (else.
8990: 20 20 20 20 28 63 61 72 20 28 73 6f 72 74 20 61 (car (sort a
89a0: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 20 ll-my-addresses
89b0: 69 70 2d 70 72 65 66 2d 6c 65 73 73 3f 29 29 29 ip-pref-less?)))
89c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 )))..(define (ge
89d0: 74 2d 61 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 t-all-ips-sorted
89e0: 29 0a 20 20 28 73 6f 72 74 20 28 67 65 74 2d 61 ). (sort (get-a
89f0: 6c 6c 2d 69 70 73 29 20 69 70 2d 70 72 65 66 2d ll-ips) ip-pref-
8a00: 6c 65 73 73 3f 29 29 0a 0a 28 64 65 66 69 6e 65 less?))..(define
8a10: 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 0a 20 (get-all-ips).
8a20: 20 28 6d 61 70 20 61 64 64 72 65 73 73 2d 69 6e (map address-in
8a30: 66 6f 2d 68 6f 73 74 0a 20 20 20 20 20 20 20 28 fo-host. (
8a40: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
8a50: 78 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 61 x)... (equal? (a
8a60: 64 64 72 65 73 73 2d 69 6e 66 6f 2d 74 79 70 65 ddress-info-type
8a70: 20 78 29 20 22 74 63 70 22 29 29 0a 09 20 20 20 x) "tcp"))..
8a80: 20 20 20 20 28 61 64 64 72 65 73 73 2d 69 6e 66 (address-inf
8a90: 6f 73 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d os (get-host-nam
8aa0: 65 29 29 29 29 29 0a 0a 29 0a e)))))..).