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 72 65 73 75 6c 74 20 20 20 28 74 74 3a ((result (tt:
1090: 74 69 6d 65 64 2d 70 69 6e 67 20 68 6f 73 74 20 timed-ping host
10a0: 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 29 29 port server-id))
10b0: 0a 09 09 20 20 20 20 20 20 28 70 69 6e 67 2d 72 ... (ping-r
10c0: 65 73 20 28 63 61 72 20 72 65 73 75 6c 74 29 29 es (car result))
10d0: 0a 09 09 20 20 20 20 20 20 28 70 69 6e 67 20 20 ... (ping
10e0: 20 20 20 28 63 64 72 20 72 65 73 75 6c 74 29 29 (cdr result))
10f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1100: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1110: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
1120: 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 69 6e 67 20 log-port* "ping
1130: 74 69 6d 65 3a 20 22 20 70 69 6e 67 29 0a 09 09 time: " ping)...
1140: 20 28 63 61 73 65 20 70 69 6e 67 2d 72 65 73 0a (case ping-res.
1150: 09 09 20 20 20 28 28 72 75 6e 6e 69 6e 67 29 0a .. ((running).
1160: 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c .. (hash-tabl
1170: 65 2d 73 65 74 21 20 28 74 74 2d 63 6f 6e 6e 73 e-set! (tt-conns
1180: 20 74 74 64 61 74 29 20 64 62 66 6e 61 6d 65 20 ttdat) dbfname
1190: 63 6f 6e 6e 29 20 3b 3b 3b 20 69 73 20 74 68 69 conn) ;;; is thi
11a0: 73 20 6f 6b 20 74 6f 20 73 61 76 65 20 62 65 66 s ok to save bef
11b0: 6f 72 65 20 76 61 6c 69 64 61 74 69 6e 67 20 74 ore validating t
11c0: 68 61 74 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 hat the connecti
11d0: 6f 6e 20 69 73 20 67 6f 6f 64 3f 0a 09 09 20 20 on is good?...
11e0: 20 20 63 6f 6e 6e 29 0a 09 09 20 20 20 28 28 73 conn)... ((s
11f0: 74 61 72 74 69 6e 67 29 0a 09 09 20 20 20 20 28 tarting)... (
1200: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
1210: 35 29 0a 09 09 20 20 20 20 28 74 74 3a 63 6c 69 5)... (tt:cli
1220: 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 ent-connect-to-s
1230: 65 72 76 65 72 20 74 74 64 61 74 20 64 62 66 6e erver ttdat dbfn
1240: 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 73 ame run-id tests
1250: 75 69 74 65 29 29 0a 09 09 20 20 20 28 65 6c 73 uite))... (els
1260: 65 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 e... (let* ((
1270: 63 75 72 72 2d 73 65 63 73 20 28 63 75 72 72 65 curr-secs (curre
1280: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 nt-seconds)))...
1290: 20 20 20 20 20 20 3b 3b 20 72 6d 20 74 68 65 20 ;; rm the
12a0: 28 6c 61 73 74 20 73 65 72 76 65 72 29 20 77 6f (last server) wo
12b0: 75 6c 64 20 67 6f 20 68 65 72 65 0a 09 09 20 20 uld go here...
12c0: 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 63 75 (if (> (- cu
12d0: 72 72 2d 73 65 63 73 20 28 74 74 2d 6c 61 73 74 rr-secs (tt-last
12e0: 2d 73 65 72 76 2d 73 74 61 72 74 20 74 74 64 61 -serv-start ttda
12f0: 74 29 29 20 31 30 29 0a 09 09 09 20 20 28 62 65 t)) 10).... (be
1300: 67 69 6e 0a 09 09 09 20 20 20 20 28 74 74 2d 6c gin.... (tt-l
1310: 61 73 74 2d 73 65 72 76 2d 73 74 61 72 74 2d 73 ast-serv-start-s
1320: 65 74 21 20 74 74 64 61 74 20 63 75 72 72 2d 73 et! ttdat curr-s
1330: 65 63 73 29 0a 09 09 09 20 20 20 20 28 73 65 72 ecs).... (ser
1340: 76 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 29 29 ver-start-proc))
1350: 29 20 3b 3b 20 73 74 61 72 74 20 73 65 72 76 65 ) ;; start serve
1360: 72 20 69 66 20 33 30 20 73 65 63 20 73 69 6e 63 r if 30 sec sinc
1370: 65 20 6c 61 73 74 20 61 74 74 65 6d 70 74 0a 09 e last attempt..
1380: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
1390: 6c 65 65 70 21 20 31 29 0a 09 09 20 20 20 20 20 leep! 1)...
13a0: 20 28 74 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e (tt:client-conn
13b0: 65 63 74 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 ect-to-server tt
13c0: 64 61 74 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d dat dbfname run-
13d0: 69 64 20 74 65 73 74 73 75 69 74 65 29 29 29 29 id testsuite))))
13e0: 29 29 29 0a 09 20 20 20 20 28 65 6c 73 65 20 3b ))).. (else ;
13f0: 3b 20 6e 6f 20 67 6f 6f 64 20 73 65 72 76 65 72 ; no good server
1400: 20 66 6f 75 6e 64 2c 20 69 66 20 68 61 76 65 6e found, if haven
1410: 27 74 20 73 74 61 72 74 65 64 20 73 65 72 76 65 't started serve
1420: 72 20 69 6e 20 3e 20 35 20 73 65 63 73 2c 20 73 r in > 5 secs, s
1430: 74 61 72 74 20 61 6e 6f 74 68 65 72 0a 09 20 20 tart another..
1440: 20 20 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 (if (> (- (cu
1450: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 rrent-seconds) (
1460: 74 74 2d 6c 61 73 74 2d 73 65 72 76 2d 73 74 61 tt-last-serv-sta
1470: 72 74 20 74 74 64 61 74 29 29 20 35 29 20 3b 3b rt ttdat)) 5) ;;
1480: 20 42 55 47 20 2d 20 67 72 6f 77 20 74 68 69 73 BUG - grow this
1490: 20 6e 75 6d 62 65 72 20 72 65 61 6c 6c 79 20 64 number really d
14a0: 6f 20 6e 6f 74 20 77 61 6e 74 20 74 6f 20 73 77 o not want to sw
14b0: 61 6d 70 20 74 68 65 20 6d 61 63 68 69 6e 65 20 amp the machine
14c0: 77 69 74 68 20 73 65 72 76 65 72 73 0a 09 09 20 with servers...
14d0: 28 62 65 67 69 6e 0a 09 09 20 20 20 28 64 65 62 (begin... (deb
14e0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
14f0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1500: 74 2a 20 22 4e 6f 20 73 65 72 76 65 72 20 66 6f t* "No server fo
1510: 75 6e 64 2e 20 53 74 61 72 74 69 6e 67 20 6f 6e und. Starting on
1520: 65 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 72 75 e for run-id "ru
1530: 6e 2d 69 64 22 20 69 6e 20 64 62 66 69 6c 65 20 n-id" in dbfile
1540: 22 64 62 66 6e 61 6d 65 29 0a 09 09 20 20 20 28 "dbfname)... (
1550: 73 65 72 76 65 72 2d 73 74 61 72 74 2d 70 72 6f server-start-pro
1560: 63 29 0a 09 09 20 20 20 28 74 74 2d 6c 61 73 74 c)... (tt-last
1570: 2d 73 65 72 76 2d 73 74 61 72 74 2d 73 65 74 21 -serv-start-set!
1580: 20 74 74 64 61 74 20 28 63 75 72 72 65 6e 74 2d ttdat (current-
1590: 73 65 63 6f 6e 64 73 29 29 29 29 0a 09 20 20 20 seconds))))..
15a0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
15b0: 20 31 29 0a 09 20 20 20 20 20 28 74 74 3a 63 6c 1).. (tt:cl
15c0: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d ient-connect-to-
15d0: 73 65 72 76 65 72 20 74 74 64 61 74 20 64 62 66 server ttdat dbf
15e0: 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 name run-id test
15f0: 73 75 69 74 65 29 29 29 29 29 29 29 0a 0a 28 64 suite)))))))..(d
1600: 65 66 69 6e 65 20 28 74 74 3a 74 69 6d 65 64 2d efine (tt:timed-
1610: 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 73 ping host port s
1620: 65 72 76 65 72 2d 69 64 29 0a 20 20 28 6c 65 74 erver-id). (let
1630: 2a 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 * ((start-time (
1640: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
1650: 6f 6e 64 73 29 29 0a 09 20 28 72 65 73 75 6c 74 onds)).. (result
1660: 20 20 20 20 20 28 74 74 3a 70 69 6e 67 20 68 6f (tt:ping ho
1670: 73 74 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 st port server-i
1680: 64 29 29 29 0a 20 20 20 20 28 63 6f 6e 73 20 72 d))). (cons r
1690: 65 73 75 6c 74 20 28 2d 20 28 63 75 72 72 65 6e esult (- (curren
16a0: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 t-milliseconds)
16b0: 73 74 61 72 74 2d 74 69 6d 65 29 29 29 29 0a 20 start-time)))).
16c0: 20 20 20 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 ..(define (tt
16d0: 3a 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 :ping host port
16e0: 73 65 72 76 65 72 2d 69 64 20 23 21 6f 70 74 69 server-id #!opti
16f0: 6f 6e 61 6c 20 28 74 72 69 65 73 2d 6c 65 66 74 onal (tries-left
1700: 20 35 29 29 0a 20 20 28 6c 65 74 2a 20 20 28 28 5)). (let* ((
1710: 72 65 73 20 20 20 20 20 20 28 74 74 3a 73 65 6e res (tt:sen
1720: 64 2d 72 65 63 65 69 76 65 2d 64 69 72 65 63 74 d-receive-direct
1730: 20 68 6f 73 74 20 70 6f 72 74 20 60 28 70 69 6e host port `(pin
1740: 67 20 23 66 20 23 66 20 23 66 29 20 70 69 6e 67 g #f #f #f) ping
1750: 2d 6d 6f 64 65 3a 20 23 74 29 29 20 3b 3b 20 70 -mode: #t)) ;; p
1760: 6c 65 61 73 65 20 73 65 6e 64 20 6d 65 20 79 6f lease send me yo
1770: 75 72 20 73 65 72 76 65 72 2d 69 64 0a 09 20 20 ur server-id..
1780: 28 74 72 79 2d 61 67 61 69 6e 20 28 6c 61 6d 62 (try-again (lamb
1790: 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 da ()... (
17a0: 69 66 20 28 3e 20 74 72 69 65 73 2d 6c 65 66 74 if (> tries-left
17b0: 20 30 29 0a 09 09 09 20 20 20 28 62 65 67 69 6e 0).... (begin
17c0: 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 .... (thread
17d0: 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 09 20 20 -sleep! 1)....
17e0: 20 20 20 28 74 74 3a 70 69 6e 67 20 68 6f 73 74 (tt:ping host
17f0: 20 70 6f 72 74 20 73 65 72 76 65 72 2d 69 64 20 port server-id
1800: 28 2d 20 74 72 69 65 73 2d 6c 65 66 74 20 31 29 (- tries-left 1)
1810: 29 29 0a 09 09 09 20 20 20 23 66 29 29 29 29 0a )).... #f)))).
1820: 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 6e 65 ;;. ;; ne
1830: 65 64 20 74 77 6f 20 74 68 72 65 61 64 73 2c 20 ed two threads,
1840: 6f 6e 65 20 61 20 35 20 73 65 63 6f 6e 64 20 74 one a 5 second t
1850: 69 6d 65 72 0a 20 20 20 20 3b 3b 0a 20 20 20 20 imer. ;;.
1860: 28 6d 61 74 63 68 20 72 65 73 0a 20 20 20 20 20 (match res.
1870: 20 28 28 73 74 61 74 75 73 20 65 72 72 6d 73 67 ((status errmsg
1880: 20 72 65 73 75 6c 74 20 6d 65 74 61 29 0a 20 20 result meta).
1890: 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f (if (equal?
18a0: 20 72 65 73 75 6c 74 20 73 65 72 76 65 72 2d 69 result server-i
18b0: 64 29 0a 09 20 20 20 28 6c 65 74 2a 20 28 28 73 d).. (let* ((s
18c0: 65 72 76 65 72 2d 73 74 61 74 65 20 28 61 6c 69 erver-state (ali
18d0: 73 74 2d 72 65 66 20 27 73 73 74 61 74 65 20 6d st-ref 'sstate m
18e0: 65 74 61 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 eta))).. ;;
18f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1900: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1910: 2a 20 22 50 69 6e 67 20 74 6f 20 22 68 6f 73 74 * "Ping to "host
1920: 22 3a 22 70 6f 72 74 22 20 73 75 63 63 65 73 73 ":"port" success
1930: 66 75 6c 2e 22 29 0a 09 20 20 20 20 20 28 6f 72 ful.").. (or
1940: 20 73 65 72 76 65 72 2d 73 74 61 74 65 20 27 75 server-state 'u
1950: 6e 6b 29 29 20 3b 3b 20 74 68 65 6e 20 77 65 20 nk)) ;; then we
1960: 61 72 65 20 67 6f 6f 64 0a 09 20 20 20 28 62 65 are good.. (be
1970: 67 69 6e 0a 09 20 20 20 20 20 28 64 65 62 75 67 gin.. (debug
1980: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
1990: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
19a0: 4e 49 4e 47 3a 20 73 65 72 76 65 72 2d 69 64 20 NING: server-id
19b0: 64 6f 65 73 20 6e 6f 74 20 6d 61 74 63 68 2c 20 does not match,
19c0: 65 78 70 65 63 74 65 64 3a 20 22 73 65 72 76 65 expected: "serve
19d0: 72 2d 69 64 22 2c 20 67 6f 74 3a 20 22 72 65 73 r-id", got: "res
19e0: 75 6c 74 29 0a 09 20 20 20 20 20 23 66 29 29 29 ult).. #f)))
19f0: 0a 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 . (else.
1a00: 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
1a10: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
1a20: 6f 67 2d 70 6f 72 74 2a 20 22 72 65 73 20 6e 6f og-port* "res no
1a30: 74 20 69 6e 20 66 6f 72 6d 20 28 73 74 61 74 75 t in form (statu
1a40: 73 20 65 72 72 6d 73 67 20 72 65 73 75 6c 74 20 s errmsg result
1a50: 6d 65 74 61 29 2c 20 67 6f 74 3a 20 22 72 65 73 meta), got: "res
1a60: 29 0a 20 20 20 20 20 20 20 28 74 72 79 2d 61 67 ). (try-ag
1a70: 61 69 6e 29 29 29 29 29 0a 0a 3b 3b 20 63 6c 69 ain)))))..;; cli
1a80: 65 6e 74 20 73 69 64 65 20 68 61 6e 64 6c 65 72 ent side handler
1a90: 0a 3b 3b 0a 3b 3b 28 74 74 3a 68 61 6e 64 6c 65 .;;.;;(tt:handle
1aa0: 72 20 23 3c 74 74 3e 20 67 65 74 2d 6b 65 79 73 r #<tt> get-keys
1ab0: 20 23 66 20 28 29 20 32 20 23 66 20 22 2f 68 6f #f () 2 #f "/ho
1ac0: 6d 65 2f 6d 61 74 74 2f 64 61 74 61 2f 6d 65 67 me/matt/data/meg
1ad0: 61 74 65 73 74 2f 65 78 74 2d 74 65 73 74 73 22 atest/ext-tests"
1ae0: 20 23 66 20 22 6d 61 69 6e 2e 64 62 22 20 22 65 #f "main.db" "e
1af0: 78 74 2d 74 65 73 74 73 22 20 22 2f 68 6f 6d 65 xt-tests" "/home
1b00: 2f 6d 61 74 74 2f 64 61 74 61 2f 6d 65 67 61 74 /matt/data/megat
1b10: 65 73 74 2f 62 69 6e 2f 2e 32 32 2e 30 34 2f 2e est/bin/.22.04/.
1b20: 2e 2f 6d 65 67 61 74 65 73 74 22 29 0a 3b 3b 0a ./megatest").;;.
1b30: 28 64 65 66 69 6e 65 20 28 74 74 3a 68 61 6e 64 (define (tt:hand
1b40: 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 75 ler ttdat cmd ru
1b50: 6e 2d 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 n-id params atte
1b60: 6d 70 74 6e 75 6d 20 61 72 65 61 2d 64 61 74 20 mptnum area-dat
1b70: 61 72 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c areapath readonl
1b80: 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 y-mode dbfname t
1b90: 65 73 74 73 75 69 74 65 20 6d 74 65 78 65 29 0a estsuite mtexe).
1ba0: 20 20 3b 3b 20 4e 4f 54 45 3a 20 61 72 65 61 70 ;; NOTE: areap
1bb0: 61 74 68 20 69 73 20 70 61 73 73 65 64 20 69 6e ath is passed in
1bc0: 20 61 6e 64 20 69 6e 20 74 74 20 73 74 72 75 63 and in tt struc
1bd0: 74 2e 20 57 65 27 6c 6c 20 75 73 65 20 70 61 73 t. We'll use pas
1be0: 73 65 64 20 69 6e 20 76 61 6c 75 65 20 66 6f 72 sed in value for
1bf0: 20 6e 6f 77 2e 0a 20 20 28 6c 65 74 2a 20 28 28 now.. (let* ((
1c00: 63 6f 6e 6e 20 28 74 74 3a 63 6c 69 65 6e 74 2d conn (tt:client-
1c10: 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 65 connect-to-serve
1c20: 72 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 20 r ttdat dbfname
1c30: 72 75 6e 2d 69 64 20 74 65 73 74 73 75 69 74 65 run-id testsuite
1c40: 29 29 29 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 ))) ;; (hash-tab
1c50: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
1c60: 74 74 2d 63 6f 6e 6e 73 20 74 74 64 61 74 29 20 tt-conns ttdat)
1c70: 64 62 66 6e 61 6d 65 20 23 66 29 29 29 0a 20 20 dbfname #f))).
1c80: 20 20 28 69 66 20 63 6f 6e 6e 0a 09 3b 3b 20 68 (if conn..;; h
1c90: 61 76 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 2c 20 ave connection,
1ca0: 63 61 6c 6c 20 74 68 65 20 73 65 72 76 65 72 0a call the server.
1cb0: 09 28 6c 65 74 2a 20 28 28 72 65 73 20 28 74 74 .(let* ((res (tt
1cc0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 74 74 :send-receive tt
1cd0: 64 61 74 20 63 6f 6e 6e 20 63 6d 64 20 72 75 6e dat conn cmd run
1ce0: 2d 69 64 20 70 61 72 61 6d 73 29 29 29 0a 09 20 -id params)))..
1cf0: 20 3b 3b 20 72 65 73 20 69 73 20 28 73 74 61 74 ;; res is (stat
1d00: 75 73 20 65 72 72 6d 73 67 20 72 65 73 75 6c 74 us errmsg result
1d10: 20 6d 65 74 61 29 0a 20 20 20 20 20 20 20 20 20 meta).
1d20: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
1d30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1d40: 72 74 2a 20 22 63 6f 6e 6e 3a 22 20 63 6f 6e 6e rt* "conn:" conn
1d50: 20 22 20 72 65 73 3a 20 22 20 72 65 73 29 0a 09 " res: " res)..
1d60: 20 20 28 6d 61 74 63 68 20 72 65 73 0a 09 20 20 (match res..
1d70: 20 20 28 28 73 74 61 74 75 73 20 65 72 72 6d 73 ((status errms
1d80: 67 20 72 65 73 75 6c 74 20 6d 65 74 61 29 0a 09 g result meta)..
1d90: 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 (if (list?
1da0: 6d 65 74 61 29 0a 09 09 20 28 6c 65 74 2a 20 28 meta)... (let* (
1db0: 28 64 65 6c 61 79 2d 77 61 69 74 20 28 61 6c 69 (delay-wait (ali
1dc0: 73 74 2d 72 65 66 20 27 64 65 6c 61 79 2d 77 61 st-ref 'delay-wa
1dd0: 69 74 20 6d 65 74 61 29 29 29 0a 09 09 20 20 20 it meta)))...
1de0: 28 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 (if (and (number
1df0: 3f 20 64 65 6c 61 79 2d 77 61 69 74 29 0a 09 09 ? delay-wait)...
1e00: 09 20 20 20 20 28 3e 20 64 65 6c 61 79 2d 77 61 . (> delay-wa
1e10: 69 74 20 30 29 29 0a 09 09 20 20 20 20 20 20 20 it 0))...
1e20: 28 62 65 67 69 6e 0a 09 09 09 20 28 64 65 62 75 (begin.... (debu
1e30: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
1e40: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 lt-log-port* "Se
1e50: 72 76 65 72 20 69 73 20 6c 6f 61 64 65 64 2c 20 rver is loaded,
1e60: 64 65 6c 61 79 69 6e 67 20 22 64 65 6c 61 79 2d delaying "delay-
1e70: 77 61 69 74 22 20 73 65 63 6f 6e 64 73 22 29 0a wait" seconds").
1e80: 09 09 09 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ... (thread-slee
1e90: 70 21 20 64 65 6c 61 79 2d 77 61 69 74 29 29 29 p! delay-wait)))
1ea0: 29 29 0a 09 20 20 20 20 20 28 63 61 73 65 20 73 )).. (case s
1eb0: 74 61 74 75 73 0a 09 20 20 20 20 20 20 20 28 28 tatus.. ((
1ec0: 62 75 73 79 29 20 3b 3b 20 72 65 73 75 6c 74 20 busy) ;; result
1ed0: 77 69 6c 6c 20 62 65 20 68 6f 77 20 6c 6f 6e 67 will be how long
1ee0: 20 74 68 65 20 73 65 72 76 65 72 20 77 61 6e 74 the server want
1ef0: 73 20 79 6f 75 20 74 6f 20 64 65 6c 61 79 0a 09 s you to delay..
1f00: 09 28 6c 65 74 2a 20 28 28 64 6c 79 20 20 28 69 .(let* ((dly (i
1f10: 66 20 28 6e 75 6d 62 65 72 3f 20 72 65 73 75 6c f (number? resul
1f20: 74 29 20 72 65 73 75 6c 74 20 30 2e 31 29 29 29 t) result 0.1)))
1f30: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
1f40: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
1f50: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
1f60: 20 73 65 72 76 65 72 20 66 6f 72 20 22 64 62 66 server for "dbf
1f70: 6e 61 6d 65 22 20 69 73 20 62 75 73 79 2c 20 77 name" is busy, w
1f80: 69 6c 6c 20 74 72 79 20 61 67 61 69 6e 20 69 6e ill try again in
1f90: 20 22 64 6c 79 22 20 73 65 63 6f 6e 64 73 2e 22 "dly" seconds."
1fa0: 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c )... (thread-sl
1fb0: 65 65 70 21 20 64 6c 79 29 0a 09 09 20 20 28 74 eep! dly)... (t
1fc0: 74 3a 68 61 6e 64 6c 65 72 20 20 74 74 64 61 74 t:handler ttdat
1fd0: 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 cmd run-id para
1fe0: 6d 73 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d ms (+ attemptnum
1ff0: 20 31 29 20 61 72 65 61 2d 64 61 74 20 61 72 65 1) area-dat are
2000: 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d apath readonly-m
2010: 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 74 ode dbfname test
2020: 73 75 69 74 65 20 6d 74 65 78 65 29 29 29 0a 09 suite mtexe)))..
2030: 20 20 20 20 20 20 20 28 28 6c 6f 61 64 65 64 29 ((loaded)
2040: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
2050: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2060: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 ort* "WARNING: s
2070: 65 72 76 65 72 20 66 6f 72 20 22 64 62 66 6e 61 erver for "dbfna
2080: 6d 65 22 20 69 73 20 6c 6f 61 64 65 64 2c 20 73 me" is loaded, s
2090: 6c 6f 77 69 6e 67 20 71 75 65 72 69 65 73 2e 22 lowing queries."
20a0: 29 0a 09 09 28 74 74 3a 62 61 63 6b 6f 66 66 2d )...(tt:backoff-
20b0: 69 6e 63 72 20 28 74 74 2d 63 6f 6e 6e 2d 68 6f incr (tt-conn-ho
20c0: 73 74 20 63 6f 6e 6e 29 28 74 74 2d 63 6f 6e 6e st conn)(tt-conn
20d0: 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 09 72 -port conn))...r
20e0: 65 73 75 6c 74 29 20 3b 3b 20 28 74 74 3a 68 61 esult) ;; (tt:ha
20f0: 6e 64 6c 65 72 20 20 74 74 64 61 74 20 63 6d 64 ndler ttdat cmd
2100: 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 run-id params (
2110: 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 + attemptnum 1)
2120: 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 area-dat areapat
2130: 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 h readonly-mode
2140: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
2150: 65 20 6d 74 65 78 65 29 29 0a 09 20 20 20 20 20 e mtexe))..
2160: 20 20 28 65 6c 73 65 0a 09 09 72 65 73 75 6c 74 (else...result
2170: 29 29 29 0a 09 20 20 20 20 28 65 6c 73 65 20 3b ))).. (else ;
2180: 3b 20 64 69 64 20 6e 6f 74 20 72 65 63 65 69 76 ; did not receiv
2190: 65 20 70 72 6f 70 65 72 6c 79 20 66 6f 72 6d 61 e properly forma
21a0: 74 65 64 20 72 65 73 75 6c 74 0a 09 20 20 20 20 ted result..
21b0: 20 28 69 66 20 28 6e 6f 74 20 72 65 73 29 20 3b (if (not res) ;
21c0: 3b 20 74 74 3a 68 61 6e 64 6c 65 72 20 69 73 20 ; tt:handler is
21d0: 74 65 6c 6c 69 6e 67 20 75 73 20 74 68 61 74 20 telling us that
21e0: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 66 61 communication fa
21f0: 69 6c 65 64 0a 09 09 20 28 6c 65 74 2a 20 28 28 iled... (let* ((
2200: 68 6f 73 74 20 20 20 20 28 74 74 2d 63 6f 6e 6e host (tt-conn
2210: 2d 68 6f 73 74 20 63 6f 6e 6e 29 29 0a 09 09 09 -host conn))....
2220: 28 70 6f 72 74 20 20 20 20 28 74 74 2d 63 6f 6e (port (tt-con
2230: 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 09 n-port conn))...
2240: 09 3b 3b 20 28 64 62 66 6e 61 6d 65 20 28 74 74 .;; (dbfname (tt
2250: 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 -conn-port conn)
2260: 29 20 3b 3b 20 31 39 32 2e 31 36 38 2e 30 2e 31 ) ;; 192.168.0.1
2270: 32 37 3a 34 32 34 32 2d 37 32 36 39 32 34 3a 34 27:4242-726924:4
2280: 2e 64 62 0a 09 09 09 28 70 69 64 20 20 20 20 20 .db....(pid
2290: 28 74 74 2d 63 6f 6e 6e 2d 70 69 64 20 20 63 6f (tt-conn-pid co
22a0: 6e 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 nn)).
22b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 ;;(
22c0: 73 65 72 76 69 6e 66 20 28 74 74 2d 63 6f 6e 6e servinf (tt-conn
22d0: 2d 73 65 72 76 69 6e 66 2d 66 69 6c 65 20 63 6f -servinf-file co
22e0: 6e 6e 29 29 29 20 0a 09 09 09 28 73 65 72 76 69 nn))) ....(servi
22f0: 6e 66 20 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 nf (tt-servinf-f
2300: 69 6c 65 20 74 74 64 61 74 29 29 29 20 3b 3b 20 ile ttdat))) ;;
2310: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f (conc areapath"/
2320: 2e 73 65 72 76 69 6e 66 6f 2f 22 68 6f 73 74 22 .servinfo/"host"
2330: 3a 22 70 6f 72 74 22 2d 22 70 69 64 22 3a 22 64 :"port"-"pid":"d
2340: 62 66 6e 61 6d 65 29 29 29 20 3b 3b 20 54 4f 44 bfname))) ;; TOD
2350: 4f 2c 20 75 73 65 20 28 73 65 72 76 65 72 3a 67 O, use (server:g
2360: 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 et-servinfo-dir
2370: 61 72 65 61 70 61 74 68 29 0a 09 09 20 20 20 28 areapath)... (
2380: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
2390: 28 74 74 2d 63 6f 6e 6e 73 20 74 74 64 61 74 29 (tt-conns ttdat)
23a0: 20 64 62 66 6e 61 6d 65 20 23 66 29 0a 09 09 20 dbfname #f)...
23b0: 20 20 28 69 66 20 28 61 6e 64 20 73 65 72 76 69 (if (and servi
23c0: 6e 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nf (file-exists?
23d0: 20 73 65 72 76 69 6e 66 29 29 0a 09 09 20 20 20 servinf))...
23e0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 28 (begin.... (
23f0: 69 66 20 28 3c 20 61 74 74 65 6d 70 74 6e 75 6d if (< attemptnum
2400: 20 31 30 29 0a 09 09 09 20 20 20 20 20 28 62 65 10).... (be
2410: 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 74 gin.... (t
2420: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 hread-sleep! 0.5
2430: 29 0a 09 09 09 20 20 20 20 20 20 20 28 74 74 3a ).... (tt:
2440: 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d handler ttdat cm
2450: 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 d run-id params
2460: 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 (+ attemptnum 1)
2470: 20 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 area-dat areapa
2480: 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 th readonly-mode
2490: 20 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 dbfname testsui
24a0: 74 65 20 6d 74 65 78 65 29 29 0a 09 09 09 20 20 te mtexe))....
24b0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 (begin....
24c0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
24d0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
24e0: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 6e 6f 20 port* "INFO: no
24f0: 72 65 73 70 6f 6e 73 65 20 66 72 6f 6d 20 73 65 response from se
2500: 72 76 65 72 20 22 68 6f 73 74 22 3a 22 70 6f 72 rver "host":"por
2510: 74 22 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 29 t" for "dbfname)
2520: 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 .... (if (
2530: 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 and (file-exists
2540: 3f 20 73 65 72 76 69 6e 66 29 0a 09 09 09 09 09 ? servinf)......
2550: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
2560: 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d 6f 64 econds)(file-mod
2570: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 ification-time s
2580: 65 72 76 69 6e 66 29 29 20 36 30 29 29 0a 09 09 ervinf)) 60))...
2590: 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 .. (begin.....
25a0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
25b0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
25c0: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 22 73 -port* "INFO: "s
25d0: 65 72 76 69 6e 66 22 20 66 69 6c 65 20 73 65 65 ervinf" file see
25e0: 6d 73 20 6f 6c 64 20 61 6e 64 20 6e 6f 20 70 69 ms old and no pi
25f0: 6e 67 20 72 65 73 70 6f 6e 73 65 2c 20 72 65 6d ng response, rem
2600: 6f 76 69 6e 67 20 69 74 2e 22 29 0a 09 09 09 09 oving it.").....
2610: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
2620: 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 65 78 eptions...... ex
2630: 6e 0a 09 09 09 09 20 20 20 20 20 20 20 23 66 0a n..... #f.
2640: 09 09 09 09 20 20 20 20 20 20 20 28 64 65 6c 65 .... (dele
2650: 74 65 2d 66 69 6c 65 2a 20 73 65 72 76 69 6e 66 te-file* servinf
2660: 29 29 0a 09 09 09 09 20 20 20 20 20 28 74 74 3a ))..... (tt:
2670: 68 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d handler ttdat cm
2680: 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 d run-id params
2690: 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 (+ attemptnum 1)
26a0: 20 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 area-dat areapa
26b0: 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 th readonly-mode
26c0: 20 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 dbfname testsui
26d0: 74 65 20 6d 74 65 78 65 29 29 0a 09 09 09 09 20 te mtexe)).....
26e0: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
26f0: 20 20 3b 3b 20 73 74 61 72 74 20 73 65 72 76 65 ;; start serve
2700: 72 20 2d 20 61 64 64 72 65 73 73 65 64 20 69 6e r - addressed in
2710: 20 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d client-connect-
2720: 74 6f 2d 73 65 72 76 65 72 0a 09 09 09 09 20 20 to-server.....
2730: 20 20 20 3b 3b 20 64 65 6c 61 79 20 20 20 20 20 ;; delay
2740: 20 20 20 2d 20 61 64 64 72 65 73 73 65 64 20 69 - addressed i
2750: 6e 20 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 n client-connect
2760: 2d 74 6f 2d 73 65 72 76 65 72 0a 09 09 09 09 20 -to-server.....
2770: 20 20 20 20 3b 3b 20 74 72 79 20 61 67 61 69 6e ;; try again
2780: 0a 09 09 09 09 20 20 20 20 20 28 74 68 72 65 61 ..... (threa
2790: 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 20 3b d-sleep! 0.25) ;
27a0: 3b 20 64 75 6e 6e 6f 2c 20 49 20 74 68 69 6e 6b ; dunno, I think
27b0: 20 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 62 this needs to b
27c0: 65 20 68 65 72 65 0a 09 09 09 09 20 20 20 20 20 e here.....
27d0: 28 74 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 (tt:handler ttda
27e0: 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 t cmd run-id par
27f0: 61 6d 73 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 ams (+ attemptnu
2800: 6d 20 31 29 20 61 72 65 61 2d 64 61 74 20 61 72 m 1) area-dat ar
2810: 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d eapath readonly-
2820: 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 mode dbfname tes
2830: 74 73 75 69 74 65 20 6d 74 65 78 65 29 29 0a 09 tsuite mtexe))..
2840: 09 09 09 20 20 20 29 29 29 29 0a 09 09 20 20 20 ... ))))...
2850: 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6e 6f (begin ;; no
2860: 20 73 65 72 76 65 72 20 66 69 6c 65 2c 20 64 65 server file, de
2870: 6c 61 79 20 61 6e 64 20 74 72 79 20 61 67 61 69 lay and try agai
2880: 6e 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 n.... (debug:pri
2890: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
28a0: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 63 g-port* "INFO: c
28b0: 6f 6e 6e 65 63 74 69 6f 6e 20 74 6f 20 73 65 72 onnection to ser
28c0: 76 65 72 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 ver "host":"port
28d0: 22 20 62 72 6f 6b 65 6e 20 66 6f 72 20 22 64 62 " broken for "db
28e0: 66 6e 61 6d 65 22 2c 20 62 75 74 20 64 6f 20 6e fname", but do n
28f0: 6f 74 20 73 65 65 20 73 65 72 76 69 6e 66 20 66 ot see servinf f
2900: 69 6c 65 20 22 73 65 72 76 69 6e 66 29 0a 09 09 ile "servinf)...
2910: 09 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 . (thread-sleep!
2920: 20 30 2e 35 29 0a 09 09 09 20 28 74 74 3a 68 61 0.5).... (tt:ha
2930: 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 ndler ttdat cmd
2940: 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 2b run-id params (+
2950: 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 61 attemptnum 1) a
2960: 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 68 rea-dat areapath
2970: 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 readonly-mode d
2980: 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 65 bfname testsuite
2990: 20 6d 74 65 78 65 29 29 29 29 0a 09 09 20 28 62 mtexe))))... (b
29a0: 65 67 69 6e 20 3b 3b 20 74 68 69 73 20 63 61 73 egin ;; this cas
29b0: 65 20 69 73 20 77 68 65 72 65 20 72 65 73 20 69 e is where res i
29c0: 73 20 6d 61 6c 66 6f 72 6d 65 64 2e 20 50 72 6f s malformed. Pro
29d0: 62 61 62 6c 79 20 73 68 6f 75 6c 64 20 61 62 6f bably should abo
29e0: 72 74 0a 09 09 20 20 20 28 61 73 73 65 72 74 20 rt... (assert
29f0: 23 66 20 22 46 41 54 41 4c 3a 20 74 74 3a 68 61 #f "FATAL: tt:ha
2a00: 6e 64 6c 65 72 20 72 65 63 65 69 76 65 64 20 62 ndler received b
2a10: 61 64 20 64 61 74 61 20 22 72 65 73 29 0a 09 09 ad data "res)...
2a20: 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
2a30: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
2a40: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 67 g-port* "INFO: g
2a50: 6f 74 20 63 6f 72 72 75 70 74 20 64 61 74 61 20 ot corrupt data
2a60: 66 72 6f 6d 20 73 65 72 76 65 72 20 22 68 6f 73 from server "hos
2a70: 74 22 3a 22 70 6f 72 74 22 2c 20 22 72 65 73 22 t":"port", "res"
2a80: 2c 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 22 2c , for "dbfname",
2a90: 20 77 69 6c 6c 20 74 72 79 20 61 67 61 69 6e 2e will try again.
2aa0: 22 29 0a 09 09 20 20 20 3b 3b 20 28 74 74 3a 68 ")... ;; (tt:h
2ab0: 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d 64 andler ttdat cmd
2ac0: 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 run-id params (
2ad0: 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 + attemptnum 1)
2ae0: 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 area-dat areapat
2af0: 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 h readonly-mode
2b00: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
2b10: 65 20 6d 74 65 78 65 29 0a 09 09 20 20 20 29 29 e mtexe)... ))
2b20: 29 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 )))..(begin.. (
2b30: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
2b40: 20 3b 3b 20 6e 6f 20 63 6f 6e 6e 20 79 65 74 20 ;; no conn yet
2b50: 73 65 74 20 75 70 2c 20 67 69 76 65 20 69 74 20 set up, give it
2b60: 61 20 72 65 73 74 20 61 6e 64 20 74 72 79 20 61 a rest and try a
2b70: 67 61 69 6e 0a 09 20 20 28 74 74 3a 68 61 6e 64 gain.. (tt:hand
2b80: 6c 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 75 ler ttdat cmd ru
2b90: 6e 2d 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 n-id params atte
2ba0: 6d 70 74 6e 75 6d 20 61 72 65 61 2d 64 61 74 20 mptnum area-dat
2bb0: 61 72 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c areapath readonl
2bc0: 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 y-mode dbfname t
2bd0: 65 73 74 73 75 69 74 65 20 6d 74 65 78 65 29 29 estsuite mtexe))
2be0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 )))..(define (tt
2bf0: 3a 62 69 64 2d 66 6f 72 2d 73 65 72 76 65 72 73 :bid-for-servers
2c00: 68 69 70 20 72 75 6e 2d 69 64 29 0a 20 20 23 66 hip run-id). #f
2c10: 29 0a 0a 3b 3b 20 67 65 74 73 20 73 65 72 76 65 )..;; gets serve
2c20: 72 20 69 6e 66 6f 20 61 6e 64 20 61 70 70 65 6e r info and appen
2c30: 64 73 20 70 61 74 68 20 74 6f 20 73 65 72 76 65 ds path to serve
2c40: 72 20 66 69 6c 65 0a 3b 3b 20 73 6f 72 74 73 20 r file.;; sorts
2c50: 62 79 20 61 67 65 2c 20 6f 6c 64 65 73 74 20 66 by age, oldest f
2c60: 69 72 73 74 0a 3b 3b 0a 3b 3b 20 72 65 74 75 72 irst.;;.;; retur
2c70: 6e 73 20 6c 69 73 74 20 6f 66 20 28 68 6f 73 74 ns list of (host
2c80: 20 70 6f 72 74 20 73 74 61 72 74 73 65 63 6f 6e port startsecon
2c90: 64 73 20 73 65 72 76 65 72 2d 69 64 20 73 65 72 ds server-id ser
2ca0: 76 69 6e 66 6f 66 69 6c 65 29 0a 3b 3b 0a 28 64 vinfofile).;;.(d
2cb0: 65 66 69 6e 65 20 28 74 74 3a 67 65 74 2d 73 65 efine (tt:get-se
2cc0: 72 76 65 72 2d 69 6e 66 6f 2d 73 6f 72 74 65 64 rver-info-sorted
2cd0: 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 0a ttdat dbfname).
2ce0: 20 20 28 6c 65 74 2a 20 28 28 61 72 65 61 70 61 (let* ((areapa
2cf0: 74 68 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 th (tt-areapath
2d00: 74 74 64 61 74 29 29 0a 09 20 28 73 66 69 6c 65 ttdat)).. (sfile
2d10: 73 20 20 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 s (tt:find-ser
2d20: 76 65 72 20 61 72 65 61 70 61 74 68 20 64 62 66 ver areapath dbf
2d30: 6e 61 6d 65 29 29 0a 09 20 28 73 64 61 74 73 20 name)).. (sdats
2d40: 20 20 20 28 66 69 6c 74 65 72 20 63 61 72 20 28 (filter car (
2d50: 6d 61 70 20 74 74 3a 73 65 72 76 65 72 2d 67 65 map tt:server-ge
2d60: 74 2d 69 6e 66 6f 20 73 66 69 6c 65 73 29 29 29 t-info sfiles)))
2d70: 20 3b 3b 20 66 69 72 73 74 20 65 6c 65 6d 65 6e ;; first elemen
2d80: 74 20 69 73 20 23 66 20 69 66 20 74 68 65 20 66 t is #f if the f
2d90: 69 6c 65 20 64 69 73 61 70 70 65 61 72 65 64 20 ile disappeared
2da0: 77 68 69 6c 65 20 62 65 69 6e 67 20 72 65 61 64 while being read
2db0: 0a 09 20 28 73 6f 72 74 65 64 20 20 20 28 73 6f .. (sorted (so
2dc0: 72 74 20 73 64 61 74 73 20 28 6c 61 6d 62 64 61 rt sdats (lambda
2dd0: 20 28 61 20 62 29 0a 09 09 09 09 20 28 6c 65 74 (a b)..... (let
2de0: 2a 20 28 28 73 74 61 72 74 61 20 28 6c 69 73 74 * ((starta (list
2df0: 2d 72 65 66 20 61 20 32 29 29 0a 09 09 09 09 09 -ref a 2))......
2e00: 28 73 74 61 72 74 62 20 28 6c 69 73 74 2d 72 65 (startb (list-re
2e10: 66 20 62 20 32 29 29 29 0a 09 09 09 09 20 20 20 f b 2))).....
2e20: 28 69 66 20 28 65 71 3f 20 73 74 61 72 74 61 20 (if (eq? starta
2e30: 73 74 61 72 74 62 29 0a 09 09 09 09 20 20 20 20 startb).....
2e40: 20 20 20 28 73 74 72 69 6e 67 3e 3f 20 28 6c 69 (string>? (li
2e50: 73 74 2d 72 65 66 20 61 20 33 29 28 6c 69 73 74 st-ref a 3)(list
2e60: 2d 72 65 66 20 62 20 33 29 29 20 3b 3b 20 69 66 -ref b 3)) ;; if
2e70: 20 73 65 72 76 65 72 73 20 73 74 61 72 74 65 64 servers started
2e80: 20 61 74 20 73 61 6d 65 20 74 69 6d 65 20 6c 6f at same time lo
2e90: 6f 6b 20 61 74 20 73 65 72 76 65 72 2d 69 64 0a ok at server-id.
2ea0: 09 09 09 09 20 20 20 20 20 20 20 28 3c 20 73 74 .... (< st
2eb0: 61 72 74 61 20 73 74 61 72 74 62 29 29 29 29 29 arta startb)))))
2ec0: 29 0a 09 20 28 63 6f 75 6e 74 20 20 20 20 30 29 ).. (count 0)
2ed0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
2ee0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 65 (lambda (re
2ef0: 63 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 6f c). (if (o
2f00: 72 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 6f 72 r (> (length sor
2f10: 74 65 64 29 20 31 29 0a 09 20 20 20 20 20 20 20 ted) 1)..
2f20: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
2f30: 65 2d 70 72 69 6e 74 20 31 32 30 20 22 73 65 72 e-print 120 "ser
2f40: 76 65 72 20 69 6e 66 6f 20 73 6f 72 74 65 64 22 ver info sorted"
2f50: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
2f60: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
2f70: 6f 67 2d 70 6f 72 74 2a 20 22 53 45 52 56 45 52 og-port* "SERVER
2f80: 20 23 22 63 6f 75 6e 74 22 3a 20 22 28 73 74 72 #"count": "(str
2f90: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
2fa0: 28 6d 61 70 20 63 6f 6e 63 20 73 6f 72 74 65 64 (map conc sorted
2fb0: 29 20 22 2c 20 22 29 29 29 0a 20 20 20 20 20 20 ) ", "))).
2fc0: 20 28 73 65 74 21 20 63 6f 75 6e 74 20 28 2b 20 (set! count (+
2fd0: 63 6f 75 6e 74 20 31 29 29 29 0a 20 20 20 20 20 count 1))).
2fe0: 73 6f 72 74 65 64 29 0a 20 20 20 20 73 6f 72 74 sorted). sort
2ff0: 65 64 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e ed)). .(defin
3000: 65 20 28 74 74 3a 67 65 74 2d 63 75 72 72 65 6e e (tt:get-curren
3010: 74 2d 73 65 72 76 65 72 2d 69 6e 66 6f 20 74 74 t-server-info tt
3020: 64 61 74 20 64 62 66 6e 61 6d 65 29 0a 20 20 28 dat dbfname). (
3030: 61 73 73 65 72 74 20 28 74 74 2d 61 72 65 61 70 assert (tt-areap
3040: 61 74 68 20 74 74 64 61 74 29 20 22 46 41 54 41 ath ttdat) "FATA
3050: 4c 3a 20 61 72 65 61 70 61 74 68 20 6e 6f 74 20 L: areapath not
3060: 73 65 74 20 69 6e 20 74 74 64 61 74 2e 22 29 0a set in ttdat.").
3070: 20 20 3b 3b 0a 20 20 3b 3b 20 54 4f 44 4f 20 2d ;;. ;; TODO -
3080: 20 72 65 70 6c 61 63 65 20 6d 6f 73 74 20 6f 66 replace most of
3090: 20 62 65 6c 6f 77 20 77 69 74 68 20 74 74 3b 67 below with tt;g
30a0: 65 74 2d 73 65 72 76 65 72 2d 69 6e 66 6f 2d 73 et-server-info-s
30b0: 6f 72 74 65 64 0a 20 20 3b 3b 0a 20 20 28 6c 65 orted. ;;. (le
30c0: 74 2a 20 28 28 61 72 65 61 70 61 74 68 20 28 74 t* ((areapath (t
30d0: 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 61 74 t-areapath ttdat
30e0: 29 29 0a 09 20 28 73 66 69 6c 65 73 20 20 20 28 )).. (sfiles (
30f0: 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 72 20 61 tt:find-server a
3100: 72 65 61 70 61 74 68 20 64 62 66 6e 61 6d 65 29 reapath dbfname)
3110: 29 0a 09 20 28 73 64 61 74 73 20 20 20 20 28 66 ).. (sdats (f
3120: 69 6c 74 65 72 20 63 61 72 20 28 6d 61 70 20 74 ilter car (map t
3130: 74 3a 73 65 72 76 65 72 2d 67 65 74 2d 69 6e 66 t:server-get-inf
3140: 6f 20 73 66 69 6c 65 73 29 29 29 20 3b 3b 20 66 o sfiles))) ;; f
3150: 69 72 73 74 20 65 6c 65 6d 65 6e 74 20 69 73 20 irst element is
3160: 23 66 20 69 66 20 74 68 65 20 66 69 6c 65 20 64 #f if the file d
3170: 69 73 61 70 70 65 61 72 65 64 20 77 68 69 6c 65 isappeared while
3180: 20 62 65 69 6e 67 20 72 65 61 64 0a 09 20 28 73 being read.. (s
3190: 6f 72 74 65 64 20 20 20 28 73 6f 72 74 20 73 64 orted (sort sd
31a0: 61 74 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 ats (lambda (a b
31b0: 29 0a 09 09 09 09 20 28 3c 20 28 6c 69 73 74 2d )..... (< (list-
31c0: 72 65 66 20 61 20 32 29 28 6c 69 73 74 2d 72 65 ref a 2)(list-re
31d0: 66 20 62 20 32 29 29 29 29 29 29 0a 20 20 20 20 f b 2)))))).
31e0: 28 69 66 20 28 6e 75 6c 6c 3f 20 73 6f 72 74 65 (if (null? sorte
31f0: 64 29 0a 09 23 66 20 20 3b 3b 20 77 65 27 6c 6c d)..#f ;; we'll
3200: 20 77 61 6e 74 20 74 6f 20 77 61 69 74 20 75 6e want to wait un
3210: 74 69 6c 20 65 78 74 72 61 20 73 65 72 76 65 72 til extra server
3220: 73 20 68 61 76 65 20 65 78 69 74 65 64 0a 09 28 s have exited..(
3230: 63 61 72 20 73 6f 72 74 65 64 29 29 29 29 0a 0a car sorted))))..
3240: 28 64 65 66 69 6e 65 20 28 74 74 3a 73 65 6e 64 (define (tt:send
3250: 2d 72 65 63 65 69 76 65 20 74 74 64 61 74 20 63 -receive ttdat c
3260: 6f 6e 6e 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 onn cmd run-id p
3270: 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 arams). (let* (
3280: 28 68 6f 73 74 2d 70 6f 72 74 20 28 74 74 2d 63 (host-port (tt-c
3290: 6f 6e 6e 2d 68 6f 73 74 2d 70 6f 72 74 20 63 6f onn-host-port co
32a0: 6e 6e 29 29 20 3b 3b 20 28 63 6f 6e 63 20 28 74 nn)) ;; (conc (t
32b0: 74 2d 63 6f 6e 6e 2d 68 6f 73 74 20 63 6f 6e 6e t-conn-host conn
32c0: 29 22 3a 22 28 74 74 2d 63 6f 6e 6e 2d 70 6f 72 )":"(tt-conn-por
32d0: 74 20 63 6f 6e 6e 29 29 29 0a 09 20 28 68 6f 73 t conn))).. (hos
32e0: 74 20 20 20 20 20 20 28 74 74 2d 63 6f 6e 6e 2d t (tt-conn-
32f0: 68 6f 73 74 20 63 6f 6e 6e 29 29 0a 09 20 28 70 host conn)).. (p
3300: 6f 72 74 20 20 20 20 20 20 28 74 74 2d 63 6f 6e ort (tt-con
3310: 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 20 n-port conn))..
3320: 28 64 61 74 20 20 20 20 20 20 20 28 6c 69 73 74 (dat (list
3330: 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 cmd run-id para
3340: 6d 73 20 23 66 29 29 29 20 3b 3b 20 6e 6f 20 6d ms #f))) ;; no m
3350: 65 74 61 20 64 61 74 61 20 79 65 74 0a 20 20 20 eta data yet.
3360: 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (tt:send-receiv
3370: 65 2d 64 69 72 65 63 74 20 68 6f 73 74 20 70 6f e-direct host po
3380: 72 74 20 64 61 74 29 29 29 0a 0a 28 64 65 66 73 rt dat)))..(defs
3390: 74 72 75 63 74 20 74 74 3a 62 61 63 6b 6f 66 66 truct tt:backoff
33a0: 0a 20 20 28 6c 61 73 74 2d 69 6f 65 72 72 20 28 . (last-ioerr (
33b0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
33c0: 29 0a 20 20 28 6c 61 73 74 2d 61 64 6a 2d 74 20 ). (last-adj-t
33d0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
33e0: 29 29 0a 20 20 28 77 61 69 74 2d 64 65 6c 61 79 )). (wait-delay
33f0: 20 30 2e 31 29 29 0a 0a 28 64 65 66 69 6e 65 20 0.1))..(define
3400: 2a 74 74 3a 62 61 63 6b 6f 66 66 2d 73 6d 6f 6f *tt:backoff-smoo
3410: 74 68 69 6e 67 2a 20 28 6d 61 6b 65 2d 68 61 73 thing* (make-has
3420: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 68 6f 73 h-table)) ;; hos
3430: 74 3a 70 6f 72 74 20 3d 3e 20 6c 61 73 74 61 63 t:port => lastac
3440: 63 65 73 73 20 62 61 63 6b 6f 66 66 64 65 6c 61 cess backoffdela
3450: 79 20 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 y )..(define (tt
3460: 3a 62 61 63 6b 6f 66 66 2d 69 6e 63 72 20 68 6f :backoff-incr ho
3470: 73 74 20 70 6f 72 74 29 20 3b 3b 20 63 61 6c 6c st port) ;; call
3480: 20 69 66 20 74 63 70 20 66 61 69 6c 73 20 69 2f if tcp fails i/
3490: 6f 20 6e 65 74 0a 20 20 28 6c 65 74 2a 20 28 28 o net. (let* ((
34a0: 68 6f 73 74 2d 70 6f 72 74 20 28 63 6f 6e 63 20 host-port (conc
34b0: 68 6f 73 74 22 3a 22 70 6f 72 74 29 29 0a 09 20 host":"port))..
34c0: 28 62 6b 6f 66 66 20 20 20 20 20 28 68 61 73 68 (bkoff (hash
34d0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
34e0: 6c 74 20 2a 74 74 3a 62 61 63 6b 6f 66 66 2d 73 lt *tt:backoff-s
34f0: 6d 6f 6f 74 68 69 6e 67 2a 20 68 6f 73 74 2d 70 moothing* host-p
3500: 6f 72 74 20 23 66 29 29 29 0a 20 20 20 20 28 69 ort #f))). (i
3510: 66 20 62 6b 6f 66 66 0a 09 28 62 65 67 69 6e 0a f bkoff..(begin.
3520: 09 20 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d 6c . (tt:backoff-l
3530: 61 73 74 2d 69 6f 65 72 72 2d 73 65 74 21 20 62 ast-ioerr-set! b
3540: 6b 6f 66 66 20 28 63 75 72 72 65 6e 74 2d 73 65 koff (current-se
3550: 63 6f 6e 64 73 29 29 0a 09 20 20 28 74 74 3a 62 conds)).. (tt:b
3560: 61 63 6b 6f 66 66 2d 77 61 69 74 2d 64 65 6c 61 ackoff-wait-dela
3570: 79 2d 73 65 74 21 20 62 6b 6f 66 66 20 28 2b 20 y-set! bkoff (+
3580: 28 74 74 3a 62 61 63 6b 6f 66 66 2d 77 61 69 74 (tt:backoff-wait
3590: 2d 64 65 6c 61 79 20 62 6b 6f 66 66 29 20 30 2e -delay bkoff) 0.
35a0: 31 29 29 29 0a 09 28 68 61 73 68 2d 74 61 62 6c 1)))..(hash-tabl
35b0: 65 2d 73 65 74 21 20 2a 74 74 3a 62 61 63 6b 6f e-set! *tt:backo
35c0: 66 66 2d 73 6d 6f 6f 74 68 69 6e 67 2a 20 68 6f ff-smoothing* ho
35d0: 73 74 2d 70 6f 72 74 20 28 6d 61 6b 65 2d 74 74 st-port (make-tt
35e0: 3a 62 61 63 6b 6f 66 66 29 29 29 29 29 0a 0a 28 :backoff)))))..(
35f0: 64 65 66 69 6e 65 20 28 74 74 3a 62 61 63 6b 6f define (tt:backo
3600: 66 66 2d 64 65 63 72 2d 61 6e 64 2d 77 61 69 74 ff-decr-and-wait
3610: 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 28 6c host port). (l
3620: 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 et* ((host-port
3630: 28 63 6f 6e 63 20 68 6f 73 74 22 3a 22 70 6f 72 (conc host":"por
3640: 74 29 29 0a 09 20 28 62 6b 6f 66 66 20 20 20 20 t)).. (bkoff
3650: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3660: 2f 64 65 66 61 75 6c 74 20 2a 74 74 3a 62 61 63 /default *tt:bac
3670: 6b 6f 66 66 2d 73 6d 6f 6f 74 68 69 6e 67 2a 20 koff-smoothing*
3680: 68 6f 73 74 2d 70 6f 72 74 20 23 66 29 29 29 0a host-port #f))).
3690: 20 20 20 20 28 69 66 20 62 6b 6f 66 66 0a 09 28 (if bkoff..(
36a0: 6c 65 74 2a 20 28 28 77 61 69 74 2d 64 65 6c 61 let* ((wait-dela
36b0: 79 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d 77 61 y (tt:backoff-wa
36c0: 69 74 2d 64 65 6c 61 79 20 62 6b 6f 66 66 29 29 it-delay bkoff))
36d0: 0a 09 20 20 20 20 20 20 20 28 6c 61 73 74 2d 69 .. (last-i
36e0: 6f 65 72 72 20 28 74 74 3a 62 61 63 6b 6f 66 66 oerr (tt:backoff
36f0: 2d 6c 61 73 74 2d 69 6f 65 72 72 20 62 6b 6f 66 -last-ioerr bkof
3700: 66 29 29 0a 09 20 20 20 20 20 20 20 28 6c 61 73 f)).. (las
3710: 74 2d 61 64 6a 2d 74 20 28 74 74 3a 62 61 63 6b t-adj-t (tt:back
3720: 6f 66 66 2d 6c 61 73 74 2d 61 64 6a 2d 74 20 62 off-last-adj-t b
3730: 6b 6f 66 66 29 29 0a 09 20 20 20 20 20 20 20 28 koff)).. (
3740: 64 65 6c 74 61 20 20 20 20 20 20 28 2d 20 28 63 delta (- (c
3750: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
3760: 6c 61 73 74 2d 61 64 6a 2d 74 29 29 0a 09 20 20 last-adj-t))..
3770: 20 20 20 20 20 28 61 64 6a 20 20 20 20 20 20 20 (adj
3780: 20 28 2a 20 64 65 6c 74 61 20 30 2e 30 30 31 29 (* delta 0.001)
3790: 29 20 3b 3b 20 69 74 20 74 61 6b 65 73 20 31 30 ) ;; it takes 10
37a0: 30 20 73 65 63 6f 6e 64 73 20 74 6f 20 72 65 63 0 seconds to rec
37b0: 6f 76 65 72 20 66 72 6f 6d 20 68 69 74 74 69 6e over from hittin
37c0: 67 20 61 6e 20 69 6f 20 65 72 72 0a 09 20 20 20 g an io err..
37d0: 20 20 20 20 28 6e 65 77 2d 77 61 69 74 20 20 20 (new-wait
37e0: 28 69 66 20 28 3e 20 77 61 69 74 2d 64 65 6c 61 (if (> wait-dela
37f0: 79 20 30 29 0a 09 09 09 20 20 20 20 20 20 20 28 y 0).... (
3800: 69 66 20 28 3e 20 61 64 6a 20 77 61 69 74 2d 64 if (> adj wait-d
3810: 65 6c 61 79 29 0a 09 09 09 09 20 20 20 30 0a 09 elay)..... 0..
3820: 09 09 09 20 20 20 28 2d 20 77 61 69 74 2d 64 65 ... (- wait-de
3830: 6c 61 79 20 61 64 6a 29 29 0a 09 09 09 20 20 20 lay adj))....
3840: 20 20 20 20 30 29 29 29 0a 09 20 20 28 69 66 20 0))).. (if
3850: 28 3e 20 6e 65 77 2d 77 61 69 74 20 30 29 0a 09 (> new-wait 0)..
3860: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
3870: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e if (common:low-n
3880: 6f 69 73 65 2d 70 72 69 6e 74 20 31 30 20 22 64 oise-print 10 "d
3890: 65 6c 61 79 20 77 61 69 74 20 6d 65 73 73 61 67 elay wait messag
38a0: 65 22 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 e")... (debug
38b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
38c0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
38d0: 20 22 53 65 72 76 65 72 20 6c 6f 61 64 65 64 2c "Server loaded,
38e0: 20 44 65 6c 61 79 57 61 69 74 3a 20 22 6e 65 77 DelayWait: "new
38f0: 2d 77 61 69 74 29 29 0a 09 09 28 74 74 3a 62 61 -wait))...(tt:ba
3900: 63 6b 6f 66 66 2d 77 61 69 74 2d 64 65 6c 61 79 ckoff-wait-delay
3910: 2d 73 65 74 21 20 62 6b 6f 66 66 20 6e 65 77 2d -set! bkoff new-
3920: 77 61 69 74 29 0a 09 09 28 74 74 3a 62 61 63 6b wait)...(tt:back
3930: 6f 66 66 2d 6c 61 73 74 2d 61 64 6a 2d 74 2d 73 off-last-adj-t-s
3940: 65 74 21 20 62 6b 6f 66 66 20 28 63 75 72 72 65 et! bkoff (curre
3950: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 28 nt-seconds))...(
3960: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 6e 65 thread-sleep! ne
3970: 77 2d 77 61 69 74 29 29 0a 09 20 20 20 20 20 20 w-wait))..
3980: 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 (hash-table-dele
3990: 74 65 21 20 2a 74 74 3a 62 61 63 6b 6f 66 66 2d te! *tt:backoff-
39a0: 73 6d 6f 6f 74 68 69 6e 67 2a 20 68 6f 73 74 2d smoothing* host-
39b0: 70 6f 72 74 29 29 29 29 29 29 0a 0a 28 64 65 66 port))))))..(def
39c0: 69 6e 65 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 ine (tt:send-rec
39d0: 65 69 76 65 2d 64 69 72 65 63 74 20 68 6f 73 74 eive-direct host
39e0: 20 70 6f 72 74 20 64 61 74 20 23 21 6b 65 79 20 port dat #!key
39f0: 28 70 69 6e 67 2d 6d 6f 64 65 20 23 66 29 28 74 (ping-mode #f)(t
3a00: 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e 67 20 32 ries-remaining 2
3a10: 35 29 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 5)). (assert (n
3a20: 75 6d 62 65 72 3f 20 70 6f 72 74 29 20 22 46 41 umber? port) "FA
3a30: 54 41 4c 3a 20 74 74 3a 73 65 6e 64 2d 72 65 63 TAL: tt:send-rec
3a40: 65 69 76 65 2d 64 69 72 65 63 74 20 63 61 6c 6c eive-direct call
3a50: 65 64 20 77 69 74 68 20 70 6f 72 74 20 6e 6f 74 ed with port not
3a60: 20 61 20 6e 75 6d 62 65 72 20 22 70 6f 72 74 29 a number "port)
3a70: 0a 20 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d 64 . (tt:backoff-d
3a80: 65 63 72 2d 61 6e 64 2d 77 61 69 74 20 68 6f 73 ecr-and-wait hos
3a90: 74 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 t port). (let*
3aa0: 28 28 72 65 74 72 79 20 20 20 20 20 20 20 20 20 ((retry
3ab0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
3ac0: 20 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 (tt:send-recei
3ad0: 76 65 2d 64 69 72 65 63 74 20 68 6f 73 74 20 70 ve-direct host p
3ae0: 6f 72 74 20 64 61 74 20 74 72 69 65 73 2d 72 65 ort dat tries-re
3af0: 6d 61 69 6e 69 6e 67 3a 20 28 2d 20 74 72 69 65 maining: (- trie
3b00: 73 2d 72 65 6d 61 69 6e 69 6e 67 20 31 29 29 29 s-remaining 1)))
3b10: 29 0a 09 20 28 66 75 6c 6c 2d 65 72 72 2d 70 72 ).. (full-err-pr
3b20: 69 6e 74 20 28 6c 61 6d 62 64 61 20 28 65 78 6e int (lambda (exn
3b30: 20 6d 73 67 29 0a 09 09 09 20 20 20 28 69 66 20 msg).... (if
3b40: 28 63 6f 6e 64 69 74 69 6f 6e 3f 20 65 78 6e 29 (condition? exn)
3b50: 0a 09 09 09 20 20 20 20 20 20 20 28 62 65 67 69 .... (begi
3b60: 6e 0a 09 09 09 09 20 28 70 70 20 28 63 6f 6e 64 n..... (pp (cond
3b70: 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 ition->list exn)
3b80: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3b90: 72 74 2a 29 0a 09 09 09 09 20 28 70 70 20 64 61 rt*)..... (pp da
3ba0: 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 t *default-log-p
3bb0: 6f 72 74 2a 29 0a 09 09 09 09 20 28 64 65 62 75 ort*)..... (debu
3bc0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3bd0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 6d 73 67 lt-log-port* msg
3be0: 0a 09 09 09 09 09 20 20 20 20 20 20 22 2c 20 65 ...... ", e
3bf0: 72 72 6f 72 3a 20 22 20 20 20 20 20 28 28 63 6f rror: " ((co
3c00: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
3c10: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
3c20: 6d 65 73 73 61 67 65 29 20 20 20 65 78 6e 29 0a message) exn).
3c30: 09 09 09 09 09 20 20 20 20 20 20 22 2c 20 61 72 ..... ", ar
3c40: 67 75 6d 65 6e 74 73 3a 20 22 20 28 28 63 6f 6e guments: " ((con
3c50: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
3c60: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 61 accessor 'exn 'a
3c70: 72 67 75 6d 65 6e 74 73 29 20 65 78 6e 29 0a 09 rguments) exn)..
3c80: 09 09 09 09 20 20 20 20 20 20 22 2c 20 6c 6f 63 .... ", loc
3c90: 61 74 69 6f 6e 3a 20 22 20 20 28 28 63 6f 6e 64 ation: " ((cond
3ca0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
3cb0: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6c 6f ccessor 'exn 'lo
3cc0: 63 61 74 69 6f 6e 29 20 20 65 78 6e 29 0a 09 09 cation) exn)...
3cd0: 09 09 09 20 20 20 20 20 20 29 29 0a 09 09 09 20 ... ))....
3ce0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3cf0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
3d00: 67 2d 70 6f 72 74 2a 20 6d 73 67 20 22 28 6e 6f g-port* msg "(no
3d10: 74 65 3a 20 65 78 6e 3d 22 65 78 6e 22 2c 20 69 te: exn="exn", i
3d20: 73 20 6e 6f 74 20 61 20 63 6f 6e 64 69 74 69 6f s not a conditio
3d30: 6e 20 6f 62 6a 65 63 74 2e 22 29 29 29 29 29 0a n object."))))).
3d40: 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 (condition-c
3d50: 61 73 65 0a 20 20 20 20 20 28 6c 65 74 2d 76 61 ase. (let-va
3d60: 6c 75 65 73 20 28 28 28 69 6e 70 20 6f 75 70 29 lues (((inp oup)
3d70: 28 74 63 70 2d 63 6f 6e 6e 65 63 74 20 68 6f 73 (tcp-connect hos
3d80: 74 20 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 t port))).
3d90: 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 66 20 (let ((res (if
3da0: 28 61 6e 64 20 69 6e 70 20 6f 75 70 29 0a 09 09 (and inp oup)...
3db0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
3dc0: 28 73 65 72 69 61 6c 69 7a 65 20 64 61 74 20 6f (serialize dat o
3dd0: 75 70 29 0a 09 09 09 28 63 6c 6f 73 65 2d 6f 75 up)....(close-ou
3de0: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 tput-port oup)..
3df0: 09 09 28 64 65 73 65 72 69 61 6c 69 7a 65 20 69 ..(deserialize i
3e00: 6e 70 29 29 0a 09 09 20 20 20 20 20 20 29 29 29 np))... )))
3e10: 0a 09 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d .. (close-input-
3e20: 70 6f 72 74 20 69 6e 70 29 0a 09 20 28 6d 61 74 port inp).. (mat
3e30: 63 68 20 72 65 73 0a 09 20 20 20 28 28 72 65 73 ch res.. ((res
3e40: 75 6c 74 20 65 78 6e 2d 72 65 73 75 6c 74 20 73 ult exn-result s
3e50: 74 64 6f 75 74 2d 72 65 73 75 6c 74 29 0a 09 20 tdout-result)..
3e60: 20 20 20 28 69 66 20 65 78 6e 2d 72 65 73 75 6c (if exn-resul
3e70: 74 0a 09 09 28 66 75 6c 6c 2d 65 72 72 2d 70 72 t...(full-err-pr
3e80: 69 6e 74 20 65 78 6e 2d 72 65 73 75 6c 74 20 22 int exn-result "
3e90: 45 52 52 4f 52 3a 20 53 65 72 76 65 72 20 73 69 ERROR: Server si
3ea0: 64 65 20 65 78 63 65 70 74 69 6f 6e 20 64 65 74 de exception det
3eb0: 65 63 74 65 64 22 29 29 0a 09 20 20 20 20 28 69 ected")).. (i
3ec0: 66 20 73 74 64 6f 75 74 2d 72 65 73 75 6c 74 0a f stdout-result.
3ed0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
3ee0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3ef0: 72 74 2a 20 22 45 52 52 4f 52 3a 20 4f 75 74 70 rt* "ERROR: Outp
3f00: 75 74 20 64 65 74 65 63 74 65 64 20 6f 6e 20 73 ut detected on s
3f10: 74 64 6f 75 74 20 6f 6e 20 73 65 72 76 65 72 20 tdout on server
3f20: 73 69 64 65 20 65 78 65 63 75 74 69 6f 6e 20 3d side execution =
3f30: 3e 20 22 73 74 64 6f 75 74 2d 72 65 73 75 6c 74 > "stdout-result
3f40: 29 29 0a 09 20 20 20 20 72 65 73 75 6c 74 29 0a )).. result).
3f50: 09 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 28 . (else.. (
3f60: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3f70: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3f80: 20 22 45 52 52 4f 52 3a 20 73 65 72 76 65 72 20 "ERROR: server
3f90: 72 65 74 75 72 6e 65 64 20 6e 6f 6e 2d 73 74 61 returned non-sta
3fa0: 6e 64 61 72 64 20 6f 75 74 70 75 74 3a 20 22 72 ndard output: "r
3fb0: 65 73 29 0a 09 20 20 20 20 23 66 29 29 29 29 0a es).. #f)))).
3fc0: 20 20 20 20 20 28 65 78 6e 20 28 69 6f 2d 65 72 (exn (io-er
3fd0: 72 6f 72 29 0a 09 20 20 28 66 75 6c 6c 2d 65 72 ror).. (full-er
3fe0: 72 2d 70 72 69 6e 74 20 65 78 6e 20 20 22 45 52 r-print exn "ER
3ff0: 52 4f 52 3a 20 69 2f 6f 20 65 72 72 6f 72 22 29 ROR: i/o error")
4000: 0a 09 20 20 28 74 74 3a 62 61 63 6b 6f 66 66 2d .. (tt:backoff-
4010: 69 6e 63 72 20 68 6f 73 74 20 70 6f 72 74 29 0a incr host port).
4020: 09 20 20 23 66 29 0a 20 20 20 20 20 28 65 78 6e . #f). (exn
4030: 20 28 69 2f 6f 20 6e 65 74 29 0a 09 20 20 28 69 (i/o net).. (i
4040: 66 20 70 69 6e 67 2d 6d 6f 64 65 0a 09 20 20 20 f ping-mode..
4050: 20 20 20 23 66 0a 09 20 20 20 20 20 20 28 63 6f #f.. (co
4060: 6e 64 0a 09 20 20 20 20 20 20 20 28 28 3e 20 20 nd.. ((>
4070: 74 72 69 65 73 2d 72 65 6d 61 69 6e 69 6e 67 20 tries-remaining
4080: 34 29 20 3b 3b 20 73 65 72 76 65 72 20 6c 69 6b 4) ;; server lik
4090: 65 6c 79 20 64 65 66 75 6e 63 74 0a 09 09 28 74 ely defunct...(t
40a0: 74 3a 62 61 63 6b 6f 66 66 2d 69 6e 63 72 20 68 t:backoff-incr h
40b0: 6f 73 74 20 70 6f 72 74 29 0a 09 09 23 66 29 0a ost port)...#f).
40c0: 09 20 20 20 20 20 20 20 28 28 3e 3d 20 74 72 69 . ((>= tri
40d0: 65 73 2d 72 65 6d 61 69 6e 69 6e 67 20 30 29 0a es-remaining 0).
40e0: 09 09 28 6c 65 74 2a 20 28 28 62 61 63 6b 6f 66 ..(let* ((backof
40f0: 66 2d 64 65 6c 61 79 20 28 6d 61 78 20 28 2a 20 f-delay (max (*
4100: 28 2d 20 32 36 20 74 72 69 65 73 2d 72 65 6d 61 (- 26 tries-rema
4110: 69 6e 69 6e 67 29 20 30 2e 31 29 20 31 2e 30 29 ining) 0.1) 1.0)
4120: 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 ))... (debug:pr
4130: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
4140: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
4150: 47 3a 20 54 43 50 20 6f 76 65 72 6c 6f 61 64 2c G: TCP overload,
4160: 20 74 72 79 69 6e 67 20 61 67 61 69 6e 20 69 6e trying again in
4170: 20 22 62 61 63 6b 6f 66 66 2d 64 65 6c 61 79 22 "backoff-delay"
4180: 73 2e 22 29 0a 09 09 20 20 28 74 68 72 65 61 64 s.")... (thread
4190: 2d 73 6c 65 65 70 21 20 62 61 63 6b 6f 66 66 2d -sleep! backoff-
41a0: 64 65 6c 61 79 29 0a 09 09 20 20 28 74 74 3a 62 delay)... (tt:b
41b0: 61 63 6b 6f 66 66 2d 69 6e 63 72 20 68 6f 73 74 ackoff-incr host
41c0: 20 70 6f 72 74 29 0a 09 09 20 20 28 72 65 74 72 port)... (retr
41d0: 79 29 29 0a 09 09 3b 3b 20 28 61 73 73 65 72 74 y))...;; (assert
41e0: 20 23 66 20 22 46 41 54 41 4c 3a 20 54 6f 6f 20 #f "FATAL: Too
41f0: 6d 61 6e 79 20 72 65 74 72 69 65 73 20 69 6e 20 many retries in
4200: 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d tt:send-receive-
4210: 64 69 72 65 63 74 22 29 0a 09 09 29 0a 09 20 20 direct")...)..
4220: 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 (else #f)))
4230: 29 0a 20 20 20 20 20 28 65 78 6e 20 28 29 0a 09 ). (exn ()..
4240: 20 20 28 66 75 6c 6c 2d 65 72 72 2d 70 72 69 6e (full-err-prin
4250: 74 20 65 78 6e 20 22 55 6e 68 61 6e 64 6c 65 64 t exn "Unhandled
4260: 20 65 78 63 65 70 74 69 6f 6e 20 66 72 6f 6d 20 exception from
4270: 63 6c 69 65 6e 74 20 73 69 64 65 2e 22 29 0a 09 client side.")..
4280: 20 20 23 66 29 29 29 29 0a 0a 0a 3b 3b 3d 3d 3d #f))))...;;===
4290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42d0: 3d 3d 3d 0a 3b 3b 20 73 65 72 76 65 72 0a 3b 3b ===.;; server.;;
42e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4320: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
4330: 28 74 74 3a 73 79 6e 63 2d 64 62 73 20 74 74 64 (tt:sync-dbs ttd
4340: 61 74 29 0a 20 20 23 66 29 0a 0a 3b 3b 20 73 74 at). #f)..;; st
4350: 61 72 74 20 74 68 65 20 6c 69 73 74 65 6e 65 72 art the listener
4360: 20 61 6e 64 20 73 74 61 72 74 20 72 65 73 70 6f and start respo
4370: 6e 64 69 6e 67 20 74 6f 20 72 65 71 75 65 73 74 nding to request
4380: 73 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 6f 72 s.;;.;; NOTE: or
4390: 67 61 6e 69 73 65 20 62 79 20 64 62 66 6e 61 6d ganise by dbfnam
43a0: 65 2c 20 6e 6f 74 20 72 75 6e 2d 69 64 20 73 6f e, not run-id so
43b0: 20 77 65 20 64 6f 6e 27 74 20 6e 65 65 64 0a 3b we don't need.;
43c0: 3b 20 20 20 20 20 20 20 74 6f 20 70 75 6c 6c 20 ; to pull
43d0: 69 6e 20 6d 6f 72 65 20 6d 6f 64 75 6c 65 73 0a in more modules.
43e0: 3b 3b 0a 3b 3b 20 54 68 69 73 20 69 73 20 74 68 ;;.;; This is th
43f0: 65 20 72 6f 75 74 69 6e 65 20 63 61 6c 6c 65 64 e routine called
4400: 20 69 6e 20 6d 65 67 61 74 65 73 74 2e 73 63 6d in megatest.scm
4410: 20 74 6f 20 73 74 61 72 74 20 61 20 73 65 72 76 to start a serv
4420: 65 72 0a 3b 3b 0a 3b 3b 20 53 65 72 76 65 72 20 er.;;.;; Server
4430: 76 69 61 62 69 6c 69 74 79 20 69 73 20 63 68 65 viability is che
4440: 63 6b 65 64 20 69 6e 20 6b 65 65 70 2d 72 75 6e cked in keep-run
4450: 6e 69 6e 67 2e 20 42 6c 69 6e 64 6c 79 20 73 74 ning. Blindly st
4460: 61 72 74 20 61 6e 64 20 72 75 6e 20 68 65 72 65 art and run here
4470: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 74 ..;;.(define (tt
4480: 3a 73 74 61 72 74 2d 73 65 72 76 65 72 20 61 72 :start-server ar
4490: 65 61 70 61 74 68 20 72 75 6e 2d 69 64 20 64 62 eapath run-id db
44a0: 66 6e 61 6d 65 2d 69 6e 20 68 61 6e 64 6c 65 72 fname-in handler
44b0: 20 6b 65 79 73 29 0a 20 20 28 61 73 73 65 72 74 keys). (assert
44c0: 20 61 72 65 61 70 61 74 68 20 22 46 41 54 41 4c areapath "FATAL
44d0: 3a 20 61 72 65 61 70 61 74 68 20 6e 6f 74 20 70 : areapath not p
44e0: 72 6f 76 69 64 65 64 20 66 6f 72 20 74 74 3a 73 rovided for tt:s
44f0: 74 61 72 74 2d 73 65 72 76 65 72 22 29 0a 20 20 tart-server").
4500: 3b 3b 20 69 73 20 74 68 65 72 65 20 61 6c 72 65 ;; is there alre
4510: 61 64 79 20 61 20 73 65 72 76 65 72 20 66 6f 72 ady a server for
4520: 20 74 68 69 73 20 64 62 66 69 6c 65 3f 20 54 68 this dbfile? Th
4530: 65 6e 20 65 78 69 74 2e 0a 20 20 28 6c 65 74 2a en exit.. (let*
4540: 20 28 28 74 74 64 61 74 20 20 20 28 6d 61 6b 65 ((ttdat (make
4550: 2d 74 74 20 61 72 65 61 70 61 74 68 3a 20 61 72 -tt areapath: ar
4560: 65 61 70 61 74 68 29 29 0a 09 20 28 64 62 66 6e eapath)).. (dbfn
4570: 61 6d 65 20 28 6f 72 20 64 62 66 6e 61 6d 65 2d ame (or dbfname-
4580: 69 6e 20 28 64 62 6d 6f 64 3a 72 75 6e 2d 69 64 in (dbmod:run-id
4590: 2d 3e 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 ->dbfname run-id
45a0: 29 29 29 0a 09 20 28 73 65 72 76 65 72 73 20 28 ))).. (servers (
45b0: 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 72 20 61 tt:find-server a
45c0: 72 65 61 70 61 74 68 20 64 62 66 6e 61 6d 65 29 reapath dbfname)
45d0: 29 29 20 3b 3b 20 73 68 6f 75 6c 64 20 75 73 65 )) ;; should use
45e0: 20 74 74 3a 67 65 74 2d 63 75 72 72 65 6e 74 2d tt:get-current-
45f0: 73 65 72 76 65 72 2d 69 6e 66 6f 20 69 6e 73 74 server-info inst
4600: 65 61 64 0a 20 20 20 20 28 69 66 20 28 3e 20 28 ead. (if (> (
4610: 6c 65 6e 67 74 68 20 73 65 72 76 65 72 73 29 20 length servers)
4620: 34 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 4)..(begin.. (d
4630: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
4640: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
4650: 22 49 4e 46 4f 3a 20 66 6f 75 6e 64 20 73 65 72 "INFO: found ser
4660: 76 65 72 28 73 29 20 61 6c 72 65 61 64 79 20 72 ver(s) already r
4670: 75 6e 6e 69 6e 67 20 66 6f 72 20 64 62 20 22 64 unning for db "d
4680: 62 66 6e 61 6d 65 22 2c 20 22 28 73 74 72 69 6e bfname", "(strin
4690: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 73 65 g-intersperse se
46a0: 72 76 65 72 73 20 22 2c 22 29 22 20 45 78 69 74 rvers ",")" Exit
46b0: 69 6e 67 2e 22 29 0a 09 20 20 28 65 78 69 74 29 ing.").. (exit)
46c0: 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 73 74 72 )..(let* ((dbstr
46d0: 75 63 74 20 20 20 28 64 62 6d 6f 64 3a 6f 70 65 uct (dbmod:ope
46e0: 6e 2d 64 62 6d 6f 64 64 62 20 61 72 65 61 70 61 n-dbmoddb areapa
46f0: 74 68 20 72 75 6e 2d 69 64 20 64 62 66 6e 61 6d th run-id dbfnam
4700: 65 20 28 64 62 66 69 6c 65 3a 64 62 2d 69 6e 69 e (dbfile:db-ini
4710: 74 2d 70 72 6f 63 29 20 6b 65 79 73 29 29 29 0a t-proc) keys))).
4720: 09 20 20 28 74 74 2d 68 61 6e 64 6c 65 72 2d 73 . (tt-handler-s
4730: 65 74 21 20 74 74 64 61 74 20 28 68 61 6e 64 6c et! ttdat (handl
4740: 65 72 20 64 62 73 74 72 75 63 74 29 29 0a 09 20 er dbstruct))..
4750: 20 28 6c 65 74 2a 20 28 28 74 63 70 2d 74 68 72 (let* ((tcp-thr
4760: 65 61 64 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 ead (make-thread
4770: 0a 09 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 .... (lambd
4780: 61 20 28 29 0a 09 09 09 09 28 74 74 3a 73 74 61 a ().....(tt:sta
4790: 72 74 2d 74 63 70 2d 73 65 72 76 65 72 20 74 74 rt-tcp-server tt
47a0: 64 61 74 29 29 20 3b 3b 20 73 74 61 72 74 20 74 dat)) ;; start t
47b0: 68 65 20 74 63 70 2d 73 65 72 76 65 72 20 77 68 he tcp-server wh
47c0: 69 63 68 20 61 70 70 6c 69 65 73 20 68 61 6e 64 ich applies hand
47d0: 6c 65 72 20 74 6f 20 69 6e 63 6f 6d 69 6e 67 20 ler to incoming
47e0: 64 61 74 61 0a 09 09 09 20 20 20 20 20 20 22 74 data.... "t
47f0: 63 70 2d 73 65 72 76 65 72 2d 74 68 72 65 61 64 cp-server-thread
4800: 22 29 29 0a 09 09 20 28 72 75 6e 2d 74 68 72 65 "))... (run-thre
4810: 61 64 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a ad (make-thread.
4820: 09 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ... (lambda
4830: 20 28 29 0a 09 09 09 09 28 74 74 3a 6b 65 65 70 ().....(tt:keep
4840: 2d 72 75 6e 6e 69 6e 67 20 74 74 64 61 74 20 64 -running ttdat d
4850: 62 66 6e 61 6d 65 20 64 62 73 74 72 75 63 74 29 bfname dbstruct)
4860: 29 29 29 29 0a 09 20 20 20 20 28 74 68 72 65 61 )))).. (threa
4870: 64 2d 73 74 61 72 74 21 20 74 63 70 2d 74 68 72 d-start! tcp-thr
4880: 65 61 64 29 0a 09 20 20 20 20 28 74 68 72 65 61 ead).. (threa
4890: 64 2d 73 74 61 72 74 21 20 72 75 6e 2d 74 68 72 d-start! run-thr
48a0: 65 61 64 29 0a 09 20 20 20 20 28 74 68 72 65 61 ead).. (threa
48b0: 64 2d 6a 6f 69 6e 21 20 72 75 6e 2d 74 68 72 65 d-join! run-thre
48c0: 61 64 29 20 3b 3b 20 72 75 6e 20 74 68 72 65 61 ad) ;; run threa
48d0: 64 20 77 69 6c 6c 20 65 78 69 74 20 6f 6e 20 74 d will exit on t
48e0: 69 6d 65 6f 75 74 20 6f 72 20 6f 74 68 65 72 20 imeout or other
48f0: 63 6f 6e 64 69 74 69 6f 6e 73 0a 09 20 20 20 20 conditions..
4900: 28 65 78 69 74 29 29 29 29 29 29 0a 0a 28 64 65 (exit))))))..(de
4910: 66 69 6e 65 20 28 74 74 3a 6b 65 65 70 2d 72 75 fine (tt:keep-ru
4920: 6e 6e 69 6e 67 20 74 74 64 61 74 20 64 62 66 6e nning ttdat dbfn
4930: 61 6d 65 20 64 62 73 74 72 75 63 74 29 0a 20 20 ame dbstruct).
4940: 3b 3b 20 76 65 72 66 69 79 20 63 6f 6e 6e 20 66 ;; verfiy conn f
4950: 6f 72 20 72 65 61 64 79 0a 20 20 3b 3b 20 6c 69 or ready. ;; li
4960: 73 74 65 6e 65 72 20 73 6f 63 6b 65 74 20 68 61 stener socket ha
4970: 73 20 62 65 65 6e 20 73 74 61 72 74 65 64 20 62 s been started b
4980: 79 20 74 68 69 73 20 73 74 61 67 65 0a 20 20 3b y this stage. ;
4990: 3b 20 77 61 69 74 20 66 6f 72 20 61 20 70 6f 72 ; wait for a por
49a0: 74 20 62 65 66 6f 72 65 20 63 72 65 61 74 69 6e t before creatin
49b0: 67 20 74 68 65 20 72 65 67 69 73 74 72 61 74 69 g the registrati
49c0: 6f 6e 20 66 69 6c 65 0a 20 20 3b 3b 0a 20 20 28 on file. ;;. (
49d0: 6c 65 74 2a 20 28 28 64 62 2d 6c 6f 63 6b 65 64 let* ((db-locked
49e0: 2d 69 6e 20 23 66 29 0a 09 20 28 61 72 65 61 70 -in #f).. (areap
49f0: 61 74 68 20 20 20 20 20 28 74 74 2d 61 72 65 61 ath (tt-area
4a00: 70 61 74 68 20 74 74 64 61 74 29 29 0a 09 20 28 path ttdat)).. (
4a10: 6e 6f 73 79 6e 63 64 62 70 61 74 68 20 28 63 6f nosyncdbpath (co
4a20: 6e 63 20 61 72 65 61 70 61 74 68 22 2f 2e 6d 74 nc areapath"/.mt
4a30: 64 62 22 29 29 0a 09 20 28 63 6c 65 61 6e 75 70 db")).. (cleanup
4a40: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 (lambda ()...
4a50: 20 20 28 69 66 20 28 74 74 2d 63 6c 65 61 6e 75 (if (tt-cleanu
4a60: 70 2d 70 72 6f 63 20 74 74 64 61 74 29 0a 09 09 p-proc ttdat)...
4a70: 09 28 28 74 74 2d 63 6c 65 61 6e 75 70 2d 70 72 .((tt-cleanup-pr
4a80: 6f 63 20 74 74 64 61 74 29 29 29 0a 09 09 20 20 oc ttdat)))...
4a90: 20 20 28 64 62 66 69 6c 65 3a 77 69 74 68 2d 6e (dbfile:with-n
4aa0: 6f 2d 73 79 6e 63 2d 64 62 20 6e 6f 73 79 6e 63 o-sync-db nosync
4ab0: 64 62 70 61 74 68 0a 09 09 09 09 09 20 20 20 20 dbpath......
4ac0: 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 09 09 09 (lambda (db)....
4ad0: 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
4ae0: 64 62 74 6d 70 6e 61 6d 65 20 28 64 62 72 3a 64 dbtmpname (dbr:d
4af0: 62 73 74 72 75 63 74 2d 64 62 74 6d 70 6e 61 6d bstruct-dbtmpnam
4b00: 65 20 64 62 73 74 72 75 63 74 29 29 29 0a 09 09 e dbstruct)))...
4b10: 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
4b20: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
4b30: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 75 6e 6e -log-port* "Runn
4b40: 69 6e 67 20 63 6c 65 61 6e 20 75 70 2c 20 69 6e ing clean up, in
4b50: 63 6c 75 64 69 6e 67 20 72 65 6d 6f 76 69 6e 67 cluding removing
4b60: 20 64 62 20 66 69 6c 65 20 22 64 62 74 6d 70 6e db file "dbtmpn
4b70: 61 6d 65 29 0a 09 09 09 09 09 09 28 64 62 3a 6e ame).......(db:n
4b80: 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 64 62 20 64 o-sync-del! db d
4b90: 62 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 23 3b bfname).......#;
4ba0: 28 69 66 20 64 62 74 6d 70 6e 61 6d 65 0a 09 09 (if dbtmpname...
4bb0: 09 09 09 09 20 20 20 20 28 64 65 6c 65 74 65 2d .... (delete-
4bc0: 66 69 6c 65 20 64 62 74 6d 70 6e 61 6d 65 29 29 file dbtmpname))
4bd0: 29 29 29 29 29 29 0a 20 20 20 20 28 73 65 74 21 )))))). (set!
4be0: 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 74 *server-info* t
4bf0: 74 64 61 74 29 0a 20 20 20 20 28 6c 65 74 20 6c tdat). (let l
4c00: 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 29 29 0a oop ((count 0)).
4c10: 20 20 20 20 20 20 28 69 66 20 28 3e 20 63 6f 75 (if (> cou
4c20: 6e 74 20 32 34 30 29 0a 09 20 20 28 62 65 67 69 nt 240).. (begi
4c30: 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 n.. (debug:pr
4c40: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
4c50: 6f 67 2d 70 6f 72 74 2a 20 22 46 41 54 41 4c 3a og-port* "FATAL:
4c60: 20 43 6f 75 6c 64 20 6e 6f 74 20 73 74 61 72 74 Could not start
4c70: 20 61 20 74 63 70 20 73 65 72 76 65 72 2c 20 67 a tcp server, g
4c80: 69 76 69 6e 67 20 75 70 2e 22 29 0a 09 20 20 20 iving up.")..
4c90: 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 28 69 (exit 1)).. (i
4ca0: 66 20 28 6e 6f 74 20 28 74 74 2d 70 6f 72 74 20 f (not (tt-port
4cb0: 74 74 64 61 74 29 29 20 3b 3b 20 6e 6f 20 63 6f ttdat)) ;; no co
4cc0: 6e 6e 65 63 74 69 6f 6e 20 79 65 74 0a 09 20 20 nnection yet..
4cd0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 74 68 (begin...(th
4ce0: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 read-sleep! 0.25
4cf0: 29 0a 09 09 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 )...(loop (+ cou
4d00: 6e 74 20 31 29 29 29 29 29 29 0a 20 20 20 20 0a nt 1)))))). .
4d10: 20 20 20 20 28 74 74 3a 63 72 65 61 74 65 2d 73 (tt:create-s
4d20: 65 72 76 65 72 2d 72 65 67 69 73 74 72 61 74 69 erver-registrati
4d30: 6f 6e 2d 66 69 6c 65 20 74 74 64 61 74 20 64 62 on-file ttdat db
4d40: 66 6e 61 6d 65 29 0a 20 20 20 20 3b 3b 20 6e 6f fname). ;; no
4d50: 77 20 73 74 61 72 74 20 77 61 74 63 68 69 6e 67 w start watching
4d60: 20 74 68 65 20 6c 61 73 74 2d 61 63 63 65 73 73 the last-access
4d70: 2c 20 69 66 20 69 74 20 68 61 73 6e 27 74 20 62 , if it hasn't b
4d80: 65 65 6e 20 74 6f 75 63 68 65 64 0a 20 20 20 20 een touched.
4d90: 3b 3b 20 69 6e 20 6f 76 65 72 20 74 65 6e 20 73 ;; in over ten s
4da0: 65 63 6f 6e 64 73 20 77 65 20 65 78 69 74 0a 20 econds we exit.
4db0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
4dc0: 21 20 30 2e 30 35 29 20 3b 3b 20 61 6e 79 20 72 ! 0.05) ;; any r
4dd0: 65 61 6c 20 6e 65 65 64 20 66 6f 72 20 64 65 6c eal need for del
4de0: 61 79 20 68 65 72 65 3f 0a 20 20 20 20 28 6c 65 ay here?. (le
4df0: 74 20 6c 6f 6f 70 20 28 29 0a 20 20 20 20 20 20 t loop ().
4e00: 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 73 20 (let* ((servers
4e10: 28 74 74 3a 67 65 74 2d 73 65 72 76 65 72 2d 69 (tt:get-server-i
4e20: 6e 66 6f 2d 73 6f 72 74 65 64 20 74 74 64 61 74 nfo-sorted ttdat
4e30: 20 64 62 66 6e 61 6d 65 29 29 0a 09 20 20 20 20 dbfname))..
4e40: 20 28 6f 6b 20 20 20 20 20 20 28 63 6f 6e 64 0a (ok (cond.
4e50: 09 09 20 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f .. ((null?
4e60: 20 73 65 72 76 65 72 73 29 20 23 66 29 20 3b 3b servers) #f) ;;
4e70: 20 6e 6f 74 20 6f 6b 0a 09 09 20 20 20 20 20 20 not ok...
4e80: 20 28 28 65 71 75 61 6c 3f 20 28 6c 69 73 74 2d ((equal? (list-
4e90: 72 65 66 20 28 63 61 72 20 73 65 72 76 65 72 73 ref (car servers
4ea0: 29 20 36 29 20 3b 3b 20 63 6f 6d 70 61 72 65 20 ) 6) ;; compare
4eb0: 74 68 65 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 the servinfofile
4ec0: 0a 09 09 09 09 28 74 74 2d 73 65 72 76 69 6e 66 .....(tt-servinf
4ed0: 2d 66 69 6c 65 20 74 74 64 61 74 29 29 0a 09 09 -file ttdat))...
4ee0: 09 28 6c 65 74 2a 20 28 28 72 65 73 20 28 69 66 .(let* ((res (if
4ef0: 20 64 62 2d 6c 6f 63 6b 65 64 2d 69 6e 0a 09 09 db-locked-in...
4f00: 09 09 09 23 74 0a 09 09 09 09 09 28 6c 65 74 2a ...#t......(let*
4f10: 20 28 28 6c 6f 63 6b 2d 72 65 73 75 6c 74 20 20 ((lock-result
4f20: 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 70 ;; this is the p
4f30: 72 69 6d 61 72 79 20 6c 6f 63 6b 20 2d 20 6e 65 rimary lock - ne
4f40: 65 64 20 74 6f 20 64 6f 75 62 6c 65 20 76 65 72 ed to double ver
4f50: 69 66 79 20 74 68 61 74 20 67 6f 74 20 69 74 0a ify that got it.
4f60: 09 09 09 09 09 09 28 64 62 66 69 6c 65 3a 77 69 ......(dbfile:wi
4f70: 74 68 2d 6e 6f 2d 73 79 6e 63 2d 64 62 0a 09 09 th-no-sync-db...
4f80: 09 09 09 09 20 6e 6f 73 79 6e 63 64 62 70 61 74 .... nosyncdbpat
4f90: 68 0a 09 09 09 09 09 09 20 28 6c 61 6d 62 64 61 h....... (lambda
4fa0: 20 28 64 62 29 0a 09 09 09 09 09 09 20 20 20 28 (db)....... (
4fb0: 64 62 3a 6e 6f 2d 73 79 6e 63 2d 6c 6f 63 6b 2d db:no-sync-lock-
4fc0: 61 6e 64 2d 63 68 65 63 6b 20 64 62 20 64 62 66 and-check db dbf
4fd0: 6e 61 6d 65 0a 09 09 09 09 09 09 09 09 09 20 20 name..........
4fe0: 20 20 20 20 28 74 74 2d 73 65 72 76 69 6e 66 2d (tt-servinf-
4ff0: 66 69 6c 65 20 74 74 64 61 74 29 0a 09 09 09 09 file ttdat).....
5000: 09 09 09 09 09 20 20 20 20 20 20 3b 3b 20 28 64 ..... ;; (d
5010: 62 72 3a 64 62 73 74 72 75 63 74 2d 64 62 74 6d br:dbstruct-dbtm
5020: 70 6e 61 6d 65 20 64 62 73 74 72 75 63 74 29 0a pname dbstruct).
5030: 09 09 09 09 09 09 09 09 09 20 20 20 20 20 20 29 ......... )
5040: 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 )))......
5050: 28 73 75 63 63 65 73 73 20 28 63 61 72 20 6c 6f (success (car lo
5060: 63 6b 2d 72 65 73 75 6c 74 29 29 29 0a 09 09 09 ck-result)))....
5070: 09 09 20 20 28 69 66 20 73 75 63 63 65 73 73 0a .. (if success.
5080: 09 09 09 09 09 20 20 20 20 20 20 28 62 65 67 69 ..... (begi
5090: 6e 0a 09 09 09 09 09 09 28 74 74 2d 73 74 61 74 n.......(tt-stat
50a0: 65 2d 73 65 74 21 20 74 74 64 61 74 20 27 72 75 e-set! ttdat 'ru
50b0: 6e 6e 69 6e 67 29 0a 09 09 09 09 09 09 28 64 65 nning).......(de
50c0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
50d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
50e0: 47 6f 74 20 73 65 72 76 65 72 20 6c 6f 63 6b 20 Got server lock
50f0: 66 6f 72 20 22 20 64 62 66 6e 61 6d 65 29 0a 09 for " dbfname)..
5100: 09 09 09 09 09 28 73 65 74 21 20 64 62 2d 6c 6f .....(set! db-lo
5110: 63 6b 65 64 2d 69 6e 20 23 74 29 0a 09 09 09 09 cked-in #t).....
5120: 09 09 23 74 29 0a 09 09 09 09 09 20 20 20 20 20 ..#t)......
5130: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 28 64 (begin.......(d
5140: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
5150: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5160: 22 46 61 69 6c 65 64 20 74 6f 20 67 65 74 20 73 "Failed to get s
5170: 65 72 76 65 72 20 6c 6f 63 6b 20 66 6f 72 20 22 erver lock for "
5180: 64 62 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 23 dbfname).......#
5190: 66 29 29 29 29 29 29 0a 09 09 09 20 20 28 69 66 f)))))).... (if
51a0: 20 28 61 6e 64 20 72 65 73 20 28 63 6f 6d 6d 6f (and res (commo
51b0: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
51c0: 74 20 31 32 30 20 22 74 6f 70 20 73 65 72 76 65 t 120 "top serve
51d0: 72 20 6d 65 73 73 61 67 65 22 29 29 0a 09 09 09 r message"))....
51e0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
51f0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
5200: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4b 65 lt-log-port* "Ke
5210: 65 70 20 72 75 6e 6e 69 6e 67 2c 20 49 27 6d 20 ep running, I'm
5220: 74 68 65 20 74 6f 70 20 73 65 72 76 65 72 20 66 the top server f
5230: 6f 72 20 22 0a 09 09 09 09 09 09 64 62 66 6e 61 or ".......dbfna
5240: 6d 65 22 20 6f 6e 20 22 28 74 74 2d 68 6f 73 74 me" on "(tt-host
5250: 20 74 74 64 61 74 29 22 3a 22 28 74 74 2d 70 6f ttdat)":"(tt-po
5260: 72 74 20 74 74 64 61 74 29 29 29 0a 09 09 09 20 rt ttdat)))....
5270: 20 72 65 73 29 29 0a 09 09 20 20 20 20 20 20 20 res))...
5280: 28 65 6c 73 65 0a 09 09 09 28 64 65 62 75 67 3a (else....(debug:
5290: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
52a0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
52b0: 22 49 27 6d 20 6e 6f 74 20 74 68 65 20 6c 65 61 "I'm not the lea
52c0: 64 20 73 65 72 76 65 72 3a 20 22 73 65 72 76 65 d server: "serve
52d0: 72 73 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 6c rs)....(let* ((l
52e0: 65 61 64 73 72 76 20 28 63 61 72 20 73 65 72 76 eadsrv (car serv
52f0: 65 72 73 29 29 29 0a 09 09 09 20 20 28 6d 61 74 ers))).... (mat
5300: 63 68 20 6c 65 61 64 73 72 76 0a 09 09 09 20 20 ch leadsrv....
5310: 20 20 28 28 68 6f 73 74 20 70 6f 72 74 20 73 74 ((host port st
5320: 61 72 74 73 65 63 6f 6e 64 73 20 73 65 72 76 65 artseconds serve
5330: 72 2d 69 64 20 70 69 64 20 64 62 66 6e 61 6d 65 r-id pid dbfname
5340: 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a 09 servinfofile)..
5350: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 .. (let* ((r
5360: 65 73 75 6c 74 20 20 28 74 74 3a 74 69 6d 65 64 esult (tt:timed
5370: 2d 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 -ping host port
5380: 73 65 72 76 65 72 2d 69 64 29 29 0a 09 09 09 09 server-id)).....
5390: 20 20 20 20 28 72 65 73 20 20 20 20 20 28 63 61 (res (ca
53a0: 72 20 72 65 73 75 6c 74 29 29 0a 09 09 09 09 20 r result)).....
53b0: 20 20 20 28 70 69 6e 67 20 20 20 20 28 63 64 72 (ping (cdr
53c0: 20 72 65 73 75 6c 74 29 29 29 0a 09 09 09 20 20 result)))....
53d0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
53e0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
53f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 69 6e t-log-port* "Pin
5400: 67 20 74 6f 20 22 68 6f 73 74 22 3a 22 70 6f 72 g to "host":"por
5410: 74 22 2c 20 77 69 74 68 20 73 65 72 76 65 72 2d t", with server-
5420: 69 64 20 22 73 65 72 76 65 72 2d 69 64 0a 09 09 id "server-id...
5430: 09 09 09 09 20 22 2c 20 61 6e 64 20 66 69 6c 65 .... ", and file
5440: 20 22 73 65 72 76 69 6e 66 6f 66 69 6c 65 22 20 "servinfofile"
5450: 72 65 74 75 72 6e 65 64 20 22 72 65 73 29 0a 09 returned "res)..
5460: 09 09 20 20 20 20 20 20 20 28 69 66 20 72 65 73 .. (if res
5470: 0a 09 09 09 09 20 20 20 23 66 20 3b 3b 20 6e 6f ..... #f ;; no
5480: 74 20 74 68 65 20 73 65 72 76 65 72 2c 20 62 75 t the server, bu
5490: 74 20 61 6c 6c 20 67 6f 6f 64 2c 20 77 61 6e 74 t all good, want
54a0: 20 74 6f 20 65 78 69 74 0a 09 09 09 09 20 20 20 to exit.....
54b0: 28 69 66 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 (if (and (file-e
54c0: 78 69 73 74 73 3f 20 73 65 72 76 69 6e 66 6f 66 xists? servinfof
54d0: 69 6c 65 29 0a 09 09 09 09 09 20 20 28 3e 20 28 ile)...... (> (
54e0: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
54f0: 64 73 29 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 ds)(file-modific
5500: 61 74 69 6f 6e 2d 74 69 6d 65 20 73 65 72 76 69 ation-time servi
5510: 6e 66 6f 66 69 6c 65 29 29 20 33 30 29 29 0a 09 nfofile)) 30))..
5520: 09 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ... (begin..
5530: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 63 61 6e ... ;; can
5540: 27 74 20 70 69 6e 67 20 61 6e 64 20 66 69 6c 65 't ping and file
5550: 20 68 61 73 20 62 65 65 6e 20 6f 6e 20 64 69 73 has been on dis
5560: 6b 20 31 35 20 73 65 63 6f 6e 64 73 2c 20 67 6f k 15 seconds, go
5570: 20 61 68 65 61 64 20 61 6e 64 20 74 72 79 20 74 ahead and try t
5580: 6f 20 72 65 6d 6f 76 65 20 69 74 0a 09 09 09 09 o remove it.....
5590: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
55a0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
55b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 ult-log-port* "R
55c0: 65 6d 6f 76 69 6e 67 20 61 70 70 61 72 65 6e 74 emoving apparent
55d0: 6c 79 20 64 65 61 64 20 73 65 72 76 65 72 20 69 ly dead server i
55e0: 6e 66 6f 20 66 69 6c 65 3a 20 22 73 65 72 76 69 nfo file: "servi
55f0: 6e 66 6f 66 69 6c 65 29 0a 20 20 20 20 20 20 20 nfofile).
5600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5620: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
5630: 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ns.
5640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5650: 20 20 20 20 20 20 20 20 20 20 20 65 78 6e 0a 20 exn.
5660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5680: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
5690: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
56a0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
56b0: 72 72 6f 72 20 72 65 6d 6f 76 69 6e 67 20 73 65 rror removing se
56c0: 72 76 65 72 20 69 6e 66 6f 20 66 69 6c 65 3a 20 rver info file:
56d0: 22 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a 09 "servinfofile)..
56e0: 09 09 09 20 20 20 20 20 20 20 20 28 64 65 6c 65 ... (dele
56f0: 74 65 2d 66 69 6c 65 2a 20 73 65 72 76 69 6e 66 te-file* servinf
5700: 6f 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 ofile).
5710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a ).
5730: 09 09 09 09 20 20 20 20 20 20 20 23 74 29 20 3b .... #t) ;
5740: 3b 20 6e 6f 74 20 74 68 65 20 73 65 72 76 65 72 ; not the server
5750: 20 62 75 74 20 74 68 65 20 73 65 72 76 65 72 20 but the server
5760: 69 73 20 6e 6f 74 20 72 65 61 63 68 61 62 6c 65 is not reachable
5770: 0a 09 09 09 09 20 20 20 20 20 28 62 65 67 69 6e ..... (begin
5780: 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 ..... (deb
5790: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
57a0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
57b0: 27 6d 20 6e 6f 74 20 74 68 65 20 73 65 72 76 65 'm not the serve
57c0: 72 20 62 75 74 20 63 6f 75 6c 64 20 6e 6f 74 20 r but could not
57d0: 70 69 6e 67 20 22 68 6f 73 74 22 3a 22 70 6f 72 ping "host":"por
57e0: 74 22 2c 20 77 69 6c 6c 20 74 72 79 20 61 67 61 t", will try aga
57f0: 69 6e 2e 22 29 0a 09 09 09 09 20 20 20 20 20 20 in.").....
5800: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
5810: 31 29 20 3b 3b 20 6a 75 73 74 20 62 65 63 61 75 1) ;; just becau
5820: 73 65 0a 09 09 09 09 20 20 20 20 20 20 20 23 74 se..... #t
5830: 29 29 29 29 29 0a 09 09 09 20 20 20 20 28 65 6c ))))).... (el
5840: 73 65 20 3b 3b 20 73 68 6f 75 6c 64 20 6e 65 76 se ;; should nev
5850: 65 72 20 67 65 74 20 68 65 72 65 0a 09 09 09 20 er get here....
5860: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5870: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
5880: 70 6f 72 74 2a 20 22 42 41 44 20 53 45 52 56 45 port* "BAD SERVE
5890: 52 20 52 45 43 4f 52 44 3a 20 22 6c 65 61 64 73 R RECORD: "leads
58a0: 72 76 29 0a 09 09 09 20 20 20 20 20 28 61 73 73 rv).... (ass
58b0: 65 72 74 20 23 66 20 22 42 61 64 20 73 65 72 76 ert #f "Bad serv
58c0: 65 72 20 72 65 63 6f 72 64 20 22 6c 65 61 64 73 er record "leads
58d0: 72 76 29 29 29 29 29 29 29 29 0a 09 28 69 66 20 rv))))))))..(if
58e0: 6f 6b 0a 09 20 20 20 20 28 74 74 2d 6c 61 73 74 ok.. (tt-last
58f0: 2d 61 63 63 65 73 73 2d 73 65 74 21 20 74 74 64 -access-set! ttd
5900: 61 74 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 at *db-last-acce
5910: 73 73 2a 29 20 3b 3b 20 62 69 74 20 73 69 6c 6c ss*) ;; bit sill
5920: 79 2c 20 6a 75 73 74 20 75 73 65 20 64 62 2d 6c y, just use db-l
5930: 61 73 74 2d 61 63 63 65 73 73 0a 09 20 20 20 20 ast-access..
5940: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 (begin.. (d
5950: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
5960: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5970: 22 45 78 69 74 69 6e 67 20 69 6d 6d 65 64 69 61 "Exiting immedia
5980: 74 65 6c 79 22 29 0a 09 20 20 20 20 20 20 28 63 tely").. (c
5990: 6c 65 61 6e 75 70 29 0a 09 20 20 20 20 20 20 28 leanup).. (
59a0: 65 78 69 74 29 29 29 0a 0a 09 28 6c 65 74 2a 20 exit)))...(let*
59b0: 28 28 6c 61 73 74 2d 75 70 64 61 74 65 20 28 64 ((last-update (d
59c0: 62 72 3a 64 62 73 74 72 75 63 74 2d 6c 61 73 74 br:dbstruct-last
59d0: 2d 75 70 64 61 74 65 20 64 62 73 74 72 75 63 74 -update dbstruct
59e0: 29 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 )).. (curr
59f0: 2d 73 65 63 73 20 20 20 28 63 75 72 72 65 6e 74 -secs (current
5a00: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 20 28 -seconds))).. (
5a10: 69 66 20 28 61 6e 64 20 28 65 71 3f 20 28 74 74 if (and (eq? (tt
5a20: 2d 73 74 61 74 65 20 74 74 64 61 74 29 20 27 72 -state ttdat) 'r
5a30: 75 6e 6e 69 6e 67 29 0a 09 09 20 20 20 28 3e 20 unning)... (>
5a40: 28 2d 20 63 75 72 72 2d 73 65 63 73 20 6c 61 73 (- curr-secs las
5a50: 74 2d 75 70 64 61 74 65 29 20 33 29 29 20 3b 3b t-update) 3)) ;;
5a60: 20 65 76 65 72 79 20 33 2d 34 20 73 65 63 6f 6e every 3-4 secon
5a70: 64 73 20 75 70 64 61 74 65 20 74 68 65 20 64 62 ds update the db
5a80: 3f 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ?.. (begin.
5a90: 09 09 28 73 65 74 21 20 28 66 69 6c 65 2d 6d 6f ..(set! (file-mo
5aa0: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
5ab0: 28 74 74 2d 73 65 72 76 69 6e 66 2d 66 69 6c 65 (tt-servinf-file
5ac0: 20 74 74 64 61 74 29 29 20 28 63 75 72 72 65 6e ttdat)) (curren
5ad0: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 28 28 t-seconds))...((
5ae0: 64 62 72 3a 64 62 73 74 72 75 63 74 2d 73 79 6e dbr:dbstruct-syn
5af0: 63 2d 70 72 6f 63 20 64 62 73 74 72 75 63 74 29 c-proc dbstruct)
5b00: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 0a 09 09 last-update)...
5b10: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 6c 61 (dbr:dbstruct-la
5b20: 73 74 2d 75 70 64 61 74 65 2d 73 65 74 21 20 64 st-update-set! d
5b30: 62 73 74 72 75 63 74 20 63 75 72 72 2d 73 65 63 bstruct curr-sec
5b40: 73 29 29 29 29 0a 09 20 20 0a 09 28 69 66 20 28 s)))).. ..(if (
5b50: 3c 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 < (- (current-se
5b60: 63 6f 6e 64 73 29 20 28 74 74 2d 6c 61 73 74 2d conds) (tt-last-
5b70: 61 63 63 65 73 73 20 74 74 64 61 74 29 29 20 28 access ttdat)) (
5b80: 74 74 2d 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 tt-server-timeou
5b90: 74 2d 70 61 72 61 6d 29 29 0a 09 20 20 20 20 28 t-param)).. (
5ba0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 74 68 begin.. (th
5bb0: 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 read-sleep! 5)..
5bc0: 20 20 20 20 20 20 28 6c 6f 6f 70 29 29 29 29 29 (loop)))))
5bd0: 0a 20 20 20 20 28 63 6c 65 61 6e 75 70 29 0a 20 . (cleanup).
5be0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5bf0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5c00: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 53 65 72 76 ort* "INFO: Serv
5c10: 65 72 20 74 69 6d 65 64 20 6f 75 74 2c 20 65 78 er timed out, ex
5c20: 69 74 69 6e 67 2e 22 29 29 29 0a 0a 20 20 0a 3b iting."))).. .;
5c30: 3b 20 3b 3b 20 67 69 76 65 6e 20 61 6e 20 61 6c ; ;; given an al
5c40: 72 65 61 64 79 20 73 65 74 20 75 70 20 75 63 6f ready set up uco
5c50: 6e 6e 20 73 74 61 72 74 20 74 68 65 20 63 6d 64 nn start the cmd
5c60: 2d 6c 6f 6f 70 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 -loop.;; ;;.;; (
5c70: 64 65 66 69 6e 65 20 28 74 74 3a 63 6d 64 2d 6c define (tt:cmd-l
5c80: 6f 6f 70 20 74 74 64 61 74 29 0a 3b 3b 20 20 20 oop ttdat).;;
5c90: 28 6c 65 74 2a 20 28 28 73 65 72 76 2d 6c 69 73 (let* ((serv-lis
5ca0: 74 65 6e 65 72 20 28 2d 73 6f 63 6b 65 74 20 75 tener (-socket u
5cb0: 63 6f 6e 6e 29 29 0a 3b 3b 20 09 20 28 6c 69 73 conn)).;; . (lis
5cc0: 74 65 6e 65 72 20 20 20 20 20 20 28 6c 61 6d 62 tener (lamb
5cd0: 64 61 20 28 29 0a 3b 3b 20 09 09 09 20 20 28 6c da ().;; ... (l
5ce0: 65 74 20 6c 6f 6f 70 20 28 28 73 74 61 74 65 20 et loop ((state
5cf0: 27 73 74 61 72 74 29 29 0a 3b 3b 20 09 09 09 20 'start)).;; ...
5d00: 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 (let-values (
5d10: 28 28 69 6e 70 20 6f 75 70 29 28 74 63 70 2d 61 ((inp oup)(tcp-a
5d20: 63 63 65 70 74 20 73 65 72 76 2d 6c 69 73 74 65 ccept serv-liste
5d30: 6e 65 72 29 29 29 0a 3b 3b 20 09 09 09 20 20 20 ner))).;; ...
5d40: 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 ;; (mutex-loc
5d50: 6b 21 20 2a 73 65 6e 64 2d 6d 75 74 65 78 2a 29 k! *send-mutex*)
5d60: 20 3b 3b 20 44 4f 45 53 4e 27 54 20 53 45 45 4d ;; DOESN'T SEEM
5d70: 20 54 4f 20 48 45 4c 50 0a 3b 3b 20 09 09 09 20 TO HELP.;; ...
5d80: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 64 61 (let* ((rda
5d90: 74 20 20 28 64 65 73 65 72 69 61 6c 69 7a 65 20 t (deserialize
5da0: 69 6e 70 29 29 20 3b 3b 20 27 28 6d 79 2d 68 6f inp)) ;; '(my-ho
5db0: 73 74 2d 70 6f 72 74 20 71 72 79 6b 65 79 20 63 st-port qrykey c
5dc0: 6d 64 20 70 61 72 61 6d 73 29 0a 3b 3b 20 09 09 md params).;; ..
5dd0: 09 09 20 20 20 20 20 28 72 65 73 70 20 20 28 75 .. (resp (u
5de0: 6c 65 78 2d 68 61 6e 64 6c 65 72 20 75 63 6f 6e lex-handler ucon
5df0: 6e 20 72 64 61 74 29 29 29 0a 3b 3b 20 09 09 09 n rdat))).;; ...
5e00: 09 28 73 65 72 69 61 6c 69 7a 65 20 72 65 73 70 .(serialize resp
5e10: 20 6f 75 70 29 0a 3b 3b 20 09 09 09 09 28 63 6c oup).;; ....(cl
5e20: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 ose-input-port i
5e30: 6e 70 29 0a 3b 3b 20 09 09 09 09 28 63 6c 6f 73 np).;; ....(clos
5e40: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 e-output-port ou
5e50: 70 29 0a 3b 3b 20 09 09 09 09 3b 3b 20 28 6d 75 p).;; ....;; (mu
5e60: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 73 65 6e tex-unlock! *sen
5e70: 64 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 44 4f 45 d-mutex*) ;; DOE
5e80: 53 4e 27 54 20 53 45 45 4d 20 54 4f 20 48 45 4c SN'T SEEM TO HEL
5e90: 50 0a 3b 3b 20 09 09 09 09 29 0a 3b 3b 20 09 09 P.;; ....).;; ..
5ea0: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 73 74 61 . (loop sta
5eb0: 74 65 29 29 29 29 29 29 0a 3b 3b 20 20 20 20 20 te)))))).;;
5ec0: 3b 3b 20 73 74 61 72 74 20 4e 20 6f 66 20 74 68 ;; start N of th
5ed0: 65 6d 0a 3b 3b 20 20 20 20 20 28 6c 65 74 20 6c em.;; (let l
5ee0: 6f 6f 70 20 28 28 74 68 6e 75 6d 20 20 20 30 29 oop ((thnum 0)
5ef0: 0a 3b 3b 20 09 20 20 20 20 20 20 20 28 74 68 72 .;; . (thr
5f00: 65 61 64 73 20 27 28 29 29 29 0a 3b 3b 20 20 20 eads '())).;;
5f10: 20 20 20 20 28 69 66 20 28 3c 20 74 68 6e 75 6d (if (< thnum
5f20: 20 31 30 30 29 0a 3b 3b 20 09 20 20 28 6c 65 74 100).;; . (let
5f30: 2a 20 28 28 74 68 20 28 6d 61 6b 65 2d 74 68 72 * ((th (make-thr
5f40: 65 61 64 20 6c 69 73 74 65 6e 65 72 20 28 63 6f ead listener (co
5f50: 6e 63 20 22 6c 69 73 74 65 6e 65 72 22 20 74 68 nc "listener" th
5f60: 6e 75 6d 29 29 29 29 0a 3b 3b 20 09 20 20 20 20 num)))).;; .
5f70: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
5f80: 68 29 0a 3b 3b 20 09 20 20 20 20 28 6c 6f 6f 70 h).;; . (loop
5f90: 20 28 2b 20 74 68 6e 75 6d 20 31 29 0a 3b 3b 20 (+ thnum 1).;;
5fa0: 09 09 20 20 28 63 6f 6e 73 20 74 68 20 74 68 72 .. (cons th thr
5fb0: 65 61 64 73 29 29 29 0a 3b 3b 20 09 20 20 28 6d eads))).;; . (m
5fc0: 61 70 20 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 ap thread-join!
5fd0: 74 68 72 65 61 64 73 29 29 29 29 29 0a 3b 3b 20 threads))))).;;
5fe0: 0a 3b 3b 20 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 .;; .;; .;; (def
5ff0: 69 6e 65 20 28 77 61 69 74 2d 61 6e 64 2d 63 6c ine (wait-and-cl
6000: 6f 73 65 20 75 63 6f 6e 6e 29 0a 3b 3b 20 20 20 ose uconn).;;
6010: 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 28 75 (thread-join! (u
6020: 64 61 74 2d 63 6d 64 2d 74 68 72 65 61 64 20 75 dat-cmd-thread u
6030: 63 6f 6e 6e 29 29 0a 3b 3b 20 20 20 28 74 63 70 conn)).;; (tcp
6040: 2d 63 6c 6f 73 65 20 28 75 64 61 74 2d 73 6f 63 -close (udat-soc
6050: 6b 65 74 20 75 63 6f 6e 6e 29 29 29 0a 3b 3b 20 ket uconn))).;;
6060: 0a 3b 3b 20 0a 0a 28 64 65 66 69 6e 65 20 28 74 .;; ..(define (t
6070: 74 3a 73 68 75 74 64 6f 77 6e 2d 73 65 72 76 65 t:shutdown-serve
6080: 72 20 74 74 64 61 74 29 0a 20 20 28 6c 65 74 2a r ttdat). (let*
6090: 20 28 28 63 6c 65 61 6e 70 72 6f 63 20 28 74 74 ((cleanproc (tt
60a0: 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 74 74 -cleanup-proc tt
60b0: 64 61 74 29 29 0a 09 20 28 70 6f 72 74 20 20 20 dat)).. (port
60c0: 20 20 20 28 74 74 2d 70 6f 72 74 20 20 20 20 20 (tt-port
60d0: 20 20 20 20 74 74 64 61 74 29 29 29 0a 20 20 20 ttdat))).
60e0: 20 28 74 74 2d 73 74 61 74 65 2d 73 65 74 21 20 (tt-state-set!
60f0: 74 74 64 61 74 20 27 73 68 75 74 64 6f 77 6e 29 ttdat 'shutdown)
6100: 0a 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 . (portlogger
6110: 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 :open-run-close
6120: 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d 70 portlogger:set-p
6130: 6f 72 74 20 70 6f 72 74 20 22 72 65 6c 65 61 73 ort port "releas
6140: 65 64 22 29 0a 20 20 20 20 28 69 66 20 63 6c 65 ed"). (if cle
6150: 61 6e 70 72 6f 63 20 28 63 6c 65 61 6e 70 72 6f anproc (cleanpro
6160: 63 29 29 0a 20 20 20 20 28 74 63 70 2d 63 6c 6f c)). (tcp-clo
6170: 73 65 20 28 74 74 2d 73 6f 63 6b 65 74 20 74 74 se (tt-socket tt
6180: 64 61 74 29 29 20 3b 3b 20 63 6c 6f 73 65 20 75 dat)) ;; close u
6190: 70 20 70 6f 72 74 73 20 68 65 72 65 0a 20 20 20 p ports here.
61a0: 20 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 ))..;; (define
61b0: 28 77 61 69 74 2d 61 6e 64 2d 63 6c 6f 73 65 20 (wait-and-close
61c0: 75 63 6f 6e 6e 29 0a 3b 3b 20 20 20 28 74 68 72 uconn).;; (thr
61d0: 65 61 64 2d 6a 6f 69 6e 21 20 28 74 74 2d 63 6d ead-join! (tt-cm
61e0: 64 2d 74 68 72 65 61 64 20 75 63 6f 6e 6e 29 29 d-thread uconn))
61f0: 0a 3b 3b 20 20 20 28 74 63 70 2d 63 6c 6f 73 65 .;; (tcp-close
6200: 20 28 74 74 2d 73 6f 63 6b 65 74 20 75 63 6f 6e (tt-socket ucon
6210: 6e 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 n)))..;; return
6220: 73 65 72 76 69 64 0a 3b 3b 20 73 69 64 65 2d 65 servid.;; side-e
6230: 66 66 65 63 74 73 3a 0a 3b 3b 20 20 20 74 74 64 ffects:.;; ttd
6240: 61 74 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 at-cleanup-proc
6250: 69 73 20 70 6f 70 75 6c 61 74 65 64 20 77 69 74 is populated wit
6260: 68 20 66 75 6e 63 74 69 6f 6e 20 74 6f 20 72 65 h function to re
6270: 6d 6f 76 65 20 74 68 65 20 73 65 72 76 65 72 69 move the serveri
6280: 6e 66 6f 20 66 69 6c 65 0a 28 64 65 66 69 6e 65 nfo file.(define
6290: 20 28 74 74 3a 63 72 65 61 74 65 2d 73 65 72 76 (tt:create-serv
62a0: 65 72 2d 72 65 67 69 73 74 72 61 74 69 6f 6e 2d er-registration-
62b0: 66 69 6c 65 20 74 74 64 61 74 20 64 62 66 6e 61 file ttdat dbfna
62c0: 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 72 me). (let* ((ar
62d0: 65 61 70 61 74 68 20 28 74 74 2d 61 72 65 61 70 eapath (tt-areap
62e0: 61 74 68 20 74 74 64 61 74 29 29 0a 09 20 28 73 ath ttdat)).. (s
62f0: 65 72 76 64 69 72 20 20 28 74 74 3a 67 65 74 2d ervdir (tt:get-
6300: 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 servinfo-dir are
6310: 61 70 61 74 68 29 29 0a 09 20 28 68 6f 73 74 20 apath)).. (host
6320: 20 20 20 20 28 74 74 2d 68 6f 73 74 20 74 74 64 (tt-host ttd
6330: 61 74 29 29 0a 09 20 28 70 6f 72 74 20 20 20 20 at)).. (port
6340: 20 28 74 74 2d 70 6f 72 74 20 74 74 64 61 74 29 (tt-port ttdat)
6350: 29 0a 09 20 28 73 65 72 76 69 6e 66 20 28 63 6f ).. (servinf (co
6360: 6e 63 20 73 65 72 76 64 69 72 22 2f 22 68 6f 73 nc servdir"/"hos
6370: 74 22 3a 22 70 6f 72 74 22 2d 22 28 63 75 72 72 t":"port"-"(curr
6380: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 ent-process-id)"
6390: 3a 22 64 62 66 6e 61 6d 65 29 29 0a 09 20 28 73 :"dbfname)).. (s
63a0: 65 72 76 2d 69 64 20 28 74 74 3a 6d 6b 2d 73 69 erv-id (tt:mk-si
63b0: 67 6e 61 74 75 72 65 20 61 72 65 61 70 61 74 68 gnature areapath
63c0: 29 29 0a 09 20 28 63 6c 65 61 6e 2d 70 72 6f 63 )).. (clean-proc
63d0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 (lambda ()...
63e0: 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c (delete-fil
63f0: 65 2a 20 73 65 72 76 69 6e 66 29 0a 09 09 20 20 e* servinf)...
6400: 20 20 20 20 20 29 29 29 0a 20 20 20 20 28 61 73 ))). (as
6410: 73 65 72 74 20 28 61 6e 64 20 68 6f 73 74 20 70 sert (and host p
6420: 6f 72 74 29 20 22 46 41 54 41 4c 3a 20 74 74 3a ort) "FATAL: tt:
6430: 63 72 65 61 74 65 2d 73 65 72 76 65 72 2d 72 65 create-server-re
6440: 67 69 73 74 72 61 74 69 6f 6e 2d 66 69 6c 65 20 gistration-file
6450: 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f 20 63 called with no c
6460: 6f 6e 6e 2c 20 64 62 66 6e 61 6d 65 3d 22 64 62 onn, dbfname="db
6470: 66 6e 61 6d 65 29 0a 20 20 20 20 28 74 74 2d 63 fname). (tt-c
6480: 6c 65 61 6e 75 70 2d 70 72 6f 63 2d 73 65 74 21 leanup-proc-set!
6490: 20 74 74 64 61 74 20 63 6c 65 61 6e 2d 70 72 6f ttdat clean-pro
64a0: 63 29 0a 20 20 20 20 28 74 74 2d 73 65 72 76 69 c). (tt-servi
64b0: 6e 66 2d 66 69 6c 65 2d 73 65 74 21 20 74 74 64 nf-file-set! ttd
64c0: 61 74 20 73 65 72 76 69 6e 66 29 0a 20 20 20 20 at servinf).
64d0: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
64e0: 66 69 6c 65 20 73 65 72 76 69 6e 66 0a 20 20 20 file servinf.
64f0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 (lambda ()..(
6500: 70 72 69 6e 74 20 22 53 45 52 56 45 52 20 53 54 print "SERVER ST
6510: 41 52 54 45 44 3a 20 22 68 6f 73 74 22 3a 22 70 ARTED: "host":"p
6520: 6f 72 74 22 20 41 54 20 22 28 63 75 72 72 65 6e ort" AT "(curren
6530: 74 2d 73 65 63 6f 6e 64 73 29 22 20 73 65 72 76 t-seconds)" serv
6540: 65 72 2d 69 64 3a 20 22 73 65 72 76 2d 69 64 22 er-id: "serv-id"
6550: 20 70 69 64 3a 20 22 28 63 75 72 72 65 6e 74 2d pid: "(current-
6560: 70 72 6f 63 65 73 73 2d 69 64 29 22 20 64 62 66 process-id)" dbf
6570: 6e 61 6d 65 3a 20 22 64 62 66 6e 61 6d 65 29 29 name: "dbfname))
6580: 29 0a 20 20 20 20 20 20 73 65 72 76 2d 69 64 29 ). serv-id)
6590: 29 0a 0a 3b 3b 20 66 69 6e 64 20 76 61 6c 69 64 )..;; find valid
65a0: 20 73 65 72 76 65 72 0a 3b 3b 20 67 65 74 20 73 server.;; get s
65b0: 65 72 76 65 72 73 20 6c 69 73 74 65 64 2c 20 6c ervers listed, l
65c0: 61 73 74 20 70 61 72 74 20 6f 66 20 6e 61 6d 65 ast part of name
65d0: 20 6d 75 73 74 20 6d 61 74 63 68 20 3a 3c 64 62 must match :<db
65e0: 66 6e 61 6d 65 3e 0a 3b 3b 20 69 66 20 6d 6f 72 fname>.;; if mor
65f0: 65 20 74 68 61 6e 20 6f 6e 65 2c 20 77 61 69 74 e than one, wait
6600: 20 6f 6e 65 20 73 65 63 6f 6e 64 20 61 6e 64 20 one second and
6610: 6c 6f 6f 6b 20 61 67 61 69 6e 0a 3b 3b 20 66 75 look again.;; fu
6620: 74 75 72 65 3a 20 70 69 6e 67 20 6f 6c 64 65 73 ture: ping oldes
6630: 74 2c 20 69 66 20 61 6c 69 76 65 20 72 65 6d 6f t, if alive remo
6640: 76 65 20 6f 74 68 65 72 20 3a 3c 64 62 66 6e 61 ve other :<dbfna
6650: 6d 65 3e 20 66 69 6c 65 73 0a 3b 3b 0a 28 64 65 me> files.;;.(de
6660: 66 69 6e 65 20 28 74 74 3a 66 69 6e 64 2d 73 65 fine (tt:find-se
6670: 72 76 65 72 20 61 72 65 61 70 61 74 68 20 64 62 rver areapath db
6680: 66 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 fname). (let* (
6690: 28 73 65 72 76 64 69 72 20 20 28 74 74 3a 67 65 (servdir (tt:ge
66a0: 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 t-servinfo-dir a
66b0: 72 65 61 70 61 74 68 29 29 0a 09 20 28 73 66 69 reapath)).. (sfi
66c0: 6c 65 73 20 20 20 28 67 6c 6f 62 20 28 63 6f 6e les (glob (con
66d0: 63 20 73 65 72 76 64 69 72 22 2f 2a 3a 22 64 62 c servdir"/*:"db
66e0: 66 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 73 66 fname)))). sf
66f0: 69 6c 65 73 29 29 0a 0a 3b 3b 20 67 69 76 65 6e iles))..;; given
6700: 20 61 20 70 61 74 68 20 74 6f 20 61 20 73 65 72 a path to a ser
6710: 76 65 72 20 69 6e 66 6f 20 66 69 6c 65 20 72 65 ver info file re
6720: 74 75 72 6e 3a 20 68 6f 73 74 20 70 6f 72 74 20 turn: host port
6730: 73 74 61 72 74 73 65 63 6f 6e 64 73 20 73 65 72 startseconds ser
6740: 76 65 72 2d 69 64 20 70 69 64 20 64 62 66 6e 61 ver-id pid dbfna
6750: 6d 65 20 6c 6f 67 66 0a 3b 3b 20 65 78 61 6d 70 me logf.;; examp
6760: 6c 65 20 6f 66 20 77 68 61 74 20 69 74 27 73 20 le of what it's
6770: 6c 6f 6f 6b 69 6e 67 20 66 6f 72 20 69 6e 20 74 looking for in t
6780: 68 65 20 6c 6f 67 20 66 69 6c 65 3a 0a 3b 3b 20 he log file:.;;
6790: 20 20 20 20 53 45 52 56 45 52 20 53 54 41 52 54 SERVER START
67a0: 45 44 3a 20 31 30 2e 33 38 2e 31 37 35 2e 36 37 ED: 10.38.175.67
67b0: 3a 35 30 32 31 36 20 41 54 20 31 36 31 36 35 30 :50216 AT 161650
67c0: 32 33 35 30 2e 30 20 73 65 72 76 65 72 2d 69 64 2350.0 server-id
67d0: 3a 20 34 39 30 37 65 39 30 66 63 35 35 63 37 61 : 4907e90fc55c7a
67e0: 30 39 36 39 34 65 33 66 36 35 38 63 36 33 39 63 09694e3f658c639c
67f0: 66 34 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 f4 .;;.(define (
6800: 74 74 3a 73 65 72 76 65 72 2d 67 65 74 2d 69 6e tt:server-get-in
6810: 66 6f 20 6c 6f 67 66 29 0a 20 20 28 6c 65 74 20 fo logf). (let
6820: 28 28 73 65 72 76 65 72 2d 72 78 20 20 20 20 28 ((server-rx (
6830: 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 52 20 regexp "^SERVER
6840: 53 54 41 52 54 45 44 3a 20 28 5c 5c 53 2b 29 3a STARTED: (\\S+):
6850: 28 5c 5c 64 2b 29 20 41 54 20 28 5b 5c 5c 64 5c (\\d+) AT ([\\d\
6860: 5c 2e 5d 2b 29 20 73 65 72 76 65 72 2d 69 64 3a \.]+) server-id:
6870: 20 28 5c 5c 53 2b 29 20 70 69 64 3a 20 28 5c 5c (\\S+) pid: (\\
6880: 64 2b 29 20 64 62 66 6e 61 6d 65 3a 20 28 5c 5c d+) dbfname: (\\
6890: 53 2b 29 22 29 29 20 3b 3b 20 53 45 52 56 45 52 S+)")) ;; SERVER
68a0: 20 53 54 41 52 54 45 44 3a 20 68 6f 73 74 3a 70 STARTED: host:p
68b0: 6f 72 74 20 41 54 20 74 69 6d 65 73 65 63 73 20 ort AT timesecs
68c0: 73 65 72 76 65 72 20 69 64 0a 20 20 20 20 20 20 server id.
68d0: 20 20 28 64 62 70 72 65 70 2d 72 78 20 20 20 20 (dbprep-rx
68e0: 28 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 52 (regexp "^SERVER
68f0: 3a 20 64 62 70 72 65 70 22 29 29 0a 20 20 20 20 : dbprep")).
6900: 20 20 20 20 28 64 62 70 72 65 70 2d 66 6f 75 6e (dbprep-foun
6910: 64 20 30 29 0a 09 28 62 61 64 2d 64 61 74 20 20 d 0)..(bad-dat
6920: 20 20 20 20 28 6c 69 73 74 20 23 66 20 23 66 20 (list #f #f
6930: 23 66 20 23 66 20 23 66 20 23 66 20 6c 6f 67 66 #f #f #f #f logf
6940: 29 29 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 ))). (let ((
6950: 66 64 61 74 20 20 20 20 20 28 68 61 6e 64 6c 65 fdat (handle
6960: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 -exceptions....
6970: 65 78 6e 0a 09 09 20 20 20 20 20 20 20 28 62 65 exn... (be
6980: 67 69 6e 0a 09 09 09 20 3b 3b 20 57 41 52 4e 49 gin.... ;; WARNI
6990: 4e 47 3a 20 74 68 69 73 20 69 73 20 70 6f 74 65 NG: this is pote
69a0: 6e 74 69 61 6c 6c 79 20 64 61 6e 67 65 72 6f 75 ntially dangerou
69b0: 73 20 74 6f 20 62 6c 61 6e 6b 65 74 20 69 67 6e s to blanket ign
69c0: 6f 72 65 20 74 68 65 20 65 72 72 6f 72 73 0a 09 ore the errors..
69d0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
69e0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
69f0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 61 62 6c log-port* "Unabl
6a00: 65 20 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 e to get server
6a10: 69 6e 66 6f 20 66 72 6f 6d 20 22 6c 6f 67 66 22 info from "logf"
6a20: 2c 20 65 78 6e 3d 22 28 63 6f 6e 64 69 74 69 6f , exn="(conditio
6a30: 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 09 n->list exn))...
6a40: 09 20 27 28 29 29 20 3b 3b 20 6e 6f 20 69 64 65 . '()) ;; no ide
6a50: 61 20 77 68 61 74 20 77 65 6e 74 20 77 72 6f 6e a what went wron
6a60: 67 2c 20 63 61 6c 6c 20 69 74 20 61 20 62 61 64 g, call it a bad
6a70: 20 73 65 72 76 65 72 2c 20 72 65 74 75 72 6e 20 server, return
6a80: 65 6d 70 74 79 20 6c 69 73 74 0a 09 09 20 20 20 empty list...
6a90: 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d (with-input-
6aa0: 66 72 6f 6d 2d 66 69 6c 65 20 6c 6f 67 66 20 72 from-file logf r
6ab0: 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 0a 20 20 ead-lines)))).
6ac0: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
6ad0: 66 64 61 74 29 20 3b 3b 20 62 61 64 20 64 61 74 fdat) ;; bad dat
6ae0: 61 2c 20 72 65 74 75 72 6e 20 62 61 64 2d 64 61 a, return bad-da
6af0: 74 0a 09 20 20 20 62 61 64 2d 64 61 74 0a 09 20 t.. bad-dat..
6b00: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e (let loop ((in
6b10: 6c 20 20 28 63 61 72 20 66 64 61 74 29 29 0a 09 l (car fdat))..
6b20: 09 20 20 20 20 20 20 28 74 61 69 6c 20 28 63 64 . (tail (cd
6b30: 72 20 66 64 61 74 29 29 0a 09 09 20 20 20 20 20 r fdat))...
6b40: 20 28 6c 6e 75 6d 20 30 29 29 0a 09 20 20 20 20 (lnum 0))..
6b50: 20 28 6c 65 74 20 28 28 6d 6c 73 74 20 28 73 74 (let ((mlst (st
6b60: 72 69 6e 67 2d 6d 61 74 63 68 20 73 65 72 76 65 ring-match serve
6b70: 72 2d 72 78 20 69 6e 6c 29 29 0a 09 09 20 20 20 r-rx inl))...
6b80: 28 64 62 70 72 65 70 20 28 73 74 72 69 6e 67 2d (dbprep (string-
6b90: 6d 61 74 63 68 20 64 62 70 72 65 70 2d 72 78 20 match dbprep-rx
6ba0: 69 6e 6c 29 29 29 0a 09 20 20 20 20 20 20 20 28 inl))).. (
6bb0: 69 66 20 64 62 70 72 65 70 20 28 73 65 74 21 20 if dbprep (set!
6bc0: 64 62 70 72 65 70 2d 66 6f 75 6e 64 20 31 29 29 dbprep-found 1))
6bd0: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f .. (if (no
6be0: 74 20 6d 6c 73 74 29 0a 09 09 20 20 20 28 69 66 t mlst)... (if
6bf0: 20 28 3e 20 6c 6e 75 6d 20 35 30 30 29 20 3b 3b (> lnum 500) ;;
6c00: 20 67 69 76 65 20 75 70 20 69 66 20 6d 6f 72 65 give up if more
6c10: 20 74 68 61 6e 20 35 30 30 20 6c 69 6e 65 73 20 than 500 lines
6c20: 6f 66 20 73 65 72 76 65 72 20 6c 6f 67 20 72 65 of server log re
6c30: 61 64 0a 09 09 20 20 20 20 20 20 20 62 61 64 2d ad... bad-
6c40: 64 61 74 0a 09 09 20 20 20 20 20 20 20 28 69 66 dat... (if
6c50: 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 09 (null? tail)...
6c60: 09 20 20 20 62 61 64 2d 64 61 74 0a 09 09 09 20 . bad-dat....
6c70: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 (loop (car tai
6c80: 6c 29 28 63 64 72 20 74 61 69 6c 29 28 2b 20 6c l)(cdr tail)(+ l
6c90: 6e 75 6d 20 31 29 29 29 29 0a 09 09 20 20 20 28 num 1))))... (
6ca0: 6d 61 74 63 68 20 6d 6c 73 74 20 3b 3b 20 68 61 match mlst ;; ha
6cb0: 76 65 20 61 20 6e 6f 74 20 6e 75 6c 6c 20 6c 69 ve a not null li
6cc0: 73 74 0a 09 09 20 20 20 20 20 28 28 5f 20 68 6f st... ((_ ho
6cd0: 73 74 20 70 6f 72 74 20 73 74 61 72 74 20 73 65 st port start se
6ce0: 72 76 65 72 2d 69 64 20 70 69 64 20 64 62 66 6e rver-id pid dbfn
6cf0: 61 6d 65 29 0a 09 09 20 20 20 20 20 20 28 6c 69 ame)... (li
6d00: 73 74 20 68 6f 73 74 0a 09 09 09 20 20 20 20 28 st host.... (
6d10: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 string->number p
6d20: 6f 72 74 29 0a 09 09 09 20 20 20 20 28 73 74 72 ort).... (str
6d30: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 73 74 61 72 ing->number star
6d40: 74 29 0a 09 09 09 20 20 20 20 73 65 72 76 65 72 t).... server
6d50: 2d 69 64 0a 09 09 09 20 20 20 20 28 73 74 72 69 -id.... (stri
6d60: 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 69 64 29 0a ng->number pid).
6d70: 09 09 09 20 20 20 20 64 62 66 6e 61 6d 65 0a 09 ... dbfname..
6d80: 09 09 20 20 20 20 6c 6f 67 66 29 29 0a 09 09 20 .. logf))...
6d90: 20 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 (else...
6da0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
6db0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6dc0: 72 74 2a 20 22 45 52 52 4f 52 3a 20 64 69 64 20 rt* "ERROR: did
6dd0: 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 20 53 45 not recognise SE
6de0: 52 56 45 52 20 6c 69 6e 65 20 69 6e 66 6f 20 22 RVER line info "
6df0: 6d 6c 73 74 29 0a 09 09 20 20 20 20 20 20 62 61 mlst)... ba
6e00: 64 2d 64 61 74 29 29 29 29 29 29 29 29 29 0a 0a d-dat)))))))))..
6e10: 3b 3b 20 47 69 76 65 6e 20 61 6e 20 61 72 65 61 ;; Given an area
6e20: 20 70 61 74 68 2c 20 20 73 74 61 72 74 20 61 20 path, start a
6e30: 73 65 72 76 65 72 20 70 72 6f 63 65 73 73 20 20 server process
6e40: 20 20 23 23 23 20 4e 4f 54 45 20 23 23 23 20 3e ### NOTE ### >
6e50: 20 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 69 file 2>&1 .;; i
6e60: 66 20 74 68 65 20 74 61 72 67 65 74 2d 68 6f 73 f the target-hos
6e70: 74 20 69 73 20 73 65 74 20 0a 3b 3b 20 74 72 79 t is set .;; try
6e80: 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 68 61 74 running on that
6e90: 20 68 6f 73 74 0a 3b 3b 20 20 20 69 6e 63 69 64 host.;; incid
6ea0: 65 6e 74 61 6c 3a 20 72 6f 74 61 74 65 20 6c 6f ental: rotate lo
6eb0: 67 73 20 69 6e 20 6c 6f 67 73 2f 20 64 69 72 2e gs in logs/ dir.
6ec0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 20 28 74 74 .;;.(define (tt
6ed0: 3a 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 2d :server-process-
6ee0: 72 75 6e 20 61 72 65 61 70 61 74 68 20 74 65 73 run areapath tes
6ef0: 74 73 75 69 74 65 20 6d 74 65 78 65 20 72 75 6e tsuite mtexe run
6f00: 2d 69 64 20 23 21 6b 65 79 20 28 70 72 6f 66 69 -id #!key (profi
6f10: 6c 65 2d 6d 6f 64 65 20 22 22 29 29 20 3b 3b 20 le-mode "")) ;;
6f20: 61 72 65 61 70 61 74 68 20 69 73 20 2a 74 6f 70 areapath is *top
6f30: 70 61 74 68 2a 20 66 6f 72 20 61 20 67 69 76 65 path* for a give
6f40: 6e 20 74 65 73 74 73 75 69 74 65 20 61 72 65 61 n testsuite area
6f50: 0a 20 20 28 61 73 73 65 72 74 20 61 72 65 61 70 . (assert areap
6f60: 61 74 68 20 20 22 46 41 54 41 4c 3a 20 74 74 3a ath "FATAL: tt:
6f70: 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 2d 72 server-process-r
6f80: 75 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 6f 75 un called withou
6f90: 74 20 61 72 65 61 70 61 74 68 20 64 65 66 69 6e t areapath defin
6fa0: 65 64 2e 22 29 0a 20 20 28 61 73 73 65 72 74 20 ed."). (assert
6fb0: 74 65 73 74 73 75 69 74 65 20 22 46 41 54 41 4c testsuite "FATAL
6fc0: 3a 20 74 74 3a 73 65 72 76 65 72 2d 70 72 6f 63 : tt:server-proc
6fd0: 65 73 73 2d 72 75 6e 20 63 61 6c 6c 65 64 20 77 ess-run called w
6fe0: 69 74 68 6f 75 74 20 74 65 73 74 73 75 69 74 65 ithout testsuite
6ff0: 20 64 65 66 69 6e 65 64 2e 22 29 0a 20 20 28 61 defined."). (a
7000: 73 73 65 72 74 20 6d 74 65 78 65 20 20 20 20 20 ssert mtexe
7010: 22 46 41 54 41 4c 3a 20 74 74 3a 73 65 72 76 65 "FATAL: tt:serve
7020: 72 2d 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 61 r-process-run ca
7030: 6c 6c 65 64 20 77 69 74 68 6f 75 74 20 6d 74 65 lled without mte
7040: 78 65 20 64 65 66 69 6e 65 64 2e 22 29 0a 20 20 xe defined.").
7050: 3b 3b 20 6d 74 65 73 74 20 2d 73 65 72 76 65 72 ;; mtest -server
7060: 20 2d 20 2d 6d 20 74 65 73 74 73 75 69 74 65 3a - -m testsuite:
7070: 65 78 74 2d 74 65 73 74 73 20 2d 64 62 20 36 2e ext-tests -db 6.
7080: 64 62 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 66 db. (let* ((dbf
7090: 6e 61 6d 65 20 20 28 64 62 6d 6f 64 3a 72 75 6e name (dbmod:run
70a0: 2d 69 64 2d 3e 64 62 66 6e 61 6d 65 20 72 75 6e -id->dbfname run
70b0: 2d 69 64 29 29 0a 09 20 28 6c 6f 61 64 20 20 20 -id)).. (load
70c0: 20 20 28 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 (get-normalize
70d0: 64 2d 63 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 d-cpu-load)).. (
70e0: 74 72 79 69 6e 67 20 20 20 28 6c 65 6e 67 74 68 trying (length
70f0: 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 72 (tt:find-server
7100: 20 61 72 65 61 70 61 74 68 20 64 62 66 6e 61 6d areapath dbfnam
7110: 65 29 29 29 0a 09 20 28 6e 72 75 6e 20 20 20 20 e))).. (nrun
7120: 20 28 6e 75 6d 62 65 72 2d 6f 66 2d 70 72 6f 63 (number-of-proc
7130: 65 73 73 65 73 2d 72 75 6e 6e 69 6e 67 20 28 63 esses-running (c
7140: 6f 6e 63 20 22 6d 74 65 73 74 2e 2a 73 65 72 76 onc "mtest.*serv
7150: 65 72 2e 2a 22 74 65 73 74 73 75 69 74 65 22 2e er.*"testsuite".
7160: 2a 22 64 62 66 6e 61 6d 65 29 29 29 29 0a 20 20 *"dbfname)))).
7170: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 3e (cond. ((>
7180: 20 6c 6f 61 64 20 32 2e 30 29 0a 20 20 20 20 20 load 2.0).
7190: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
71a0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
71b0: 74 2a 20 22 4e 6f 72 6d 61 6c 69 7a 65 64 20 6c t* "Normalized l
71c0: 6f 61 64 20 22 6c 6f 61 64 22 20 6f 6e 20 22 20 oad "load" on "
71d0: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 (get-host-name)
71e0: 22 20 69 73 20 6f 76 65 72 20 74 68 65 20 6c 69 " is over the li
71f0: 6d 69 74 20 6f 66 20 32 2e 30 2e 20 4e 6f 74 20 mit of 2.0. Not
7200: 73 74 61 72 74 69 6e 67 20 61 20 73 65 72 76 65 starting a serve
7210: 72 2e 22 29 0a 20 20 20 20 20 20 28 74 68 72 65 r."). (thre
7220: 61 64 2d 73 6c 65 65 70 21 20 31 29 29 0a 20 20 ad-sleep! 1)).
7230: 20 20 20 28 28 3e 20 6e 72 75 6e 20 31 30 30 29 ((> nrun 100)
7240: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
7250: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
7260: 6f 67 2d 70 6f 72 74 2a 20 6e 72 75 6e 22 20 73 og-port* nrun" s
7270: 65 72 76 65 72 73 20 72 75 6e 6e 69 6e 67 20 6f ervers running o
7280: 6e 20 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 n " (get-host-na
7290: 6d 65 29 20 22 2c 20 6e 6f 74 20 73 74 61 72 74 me) ", not start
72a0: 69 6e 67 20 61 6e 6f 74 68 65 72 2e 22 29 0a 20 ing another.").
72b0: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
72c0: 65 70 21 20 31 29 29 0a 20 20 20 20 20 28 28 3e ep! 1)). ((>
72d0: 20 74 72 79 69 6e 67 20 34 29 0a 20 20 20 20 20 trying 4).
72e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
72f0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
7300: 74 2a 20 74 72 79 69 6e 67 22 20 73 65 72 76 65 t* trying" serve
7310: 72 73 20 72 65 67 69 73 74 65 72 65 64 20 69 6e rs registered in
7320: 20 2e 73 65 72 76 69 6e 66 6f 20 64 69 72 2e 20 .servinfo dir.
7330: 6e 6f 74 20 73 74 61 72 74 69 6e 67 20 61 6e 6f not starting ano
7340: 74 68 65 72 2e 22 29 0a 20 20 20 20 20 20 28 74 ther."). (t
7350: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 hread-sleep! 1))
7360: 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 . (else.
7370: 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 (if (not (file
7380: 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 61 -exists? (conc a
7390: 72 65 61 70 61 74 68 22 2f 6c 6f 67 73 22 29 29 reapath"/logs"))
73a0: 29 0a 09 20 20 20 20 20 20 28 63 72 65 61 74 65 ).. (create
73b0: 2d 64 69 72 65 63 74 6f 72 79 20 28 63 6f 6e 63 -directory (conc
73c0: 20 61 72 65 61 70 61 74 68 22 2f 6c 6f 67 73 22 areapath"/logs"
73d0: 29 20 23 74 29 29 0a 09 20 20 28 6c 65 74 2a 20 ) #t)).. (let*
73e0: 28 28 6c 6f 67 66 69 6c 65 20 20 20 28 63 6f 6e ((logfile (con
73f0: 63 20 61 72 65 61 70 61 74 68 20 22 2f 6c 6f 67 c areapath "/log
7400: 73 2f 73 65 72 76 65 72 2d 22 64 62 66 6e 61 6d s/server-"dbfnam
7410: 65 22 2d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f e"-"(current-pro
7420: 63 65 73 73 2d 69 64 29 22 2e 6c 6f 67 22 29 29 cess-id)".log"))
7430: 20 3b 3b 20 2d 22 20 63 75 72 72 2d 70 69 64 20 ;; -" curr-pid
7440: 22 2d 22 20 74 61 72 67 65 74 2d 68 6f 73 74 20 "-" target-host
7450: 22 2e 6c 6f 67 22 29 29 0a 09 09 20 28 63 6d 64 ".log"))... (cmd
7460: 6c 6e 20 20 20 20 20 28 63 6f 6e 63 0a 09 09 09 ln (conc....
7470: 20 20 20 20 20 6d 74 65 78 65 0a 09 09 09 20 20 mtexe....
7480: 20 20 20 22 20 2d 73 65 72 76 65 72 20 2d 20 22 " -server - "
7490: 3b 3b 20 28 6f 72 20 74 61 72 67 65 74 2d 68 6f ;; (or target-ho
74a0: 73 74 20 22 2d 22 29 0a 09 09 09 20 20 20 20 20 st "-")....
74b0: 22 20 2d 6d 20 74 65 73 74 73 75 69 74 65 3a 22 " -m testsuite:"
74c0: 20 74 65 73 74 73 75 69 74 65 0a 09 09 09 20 20 testsuite....
74d0: 20 20 20 3b 3b 20 22 20 2d 72 75 6e 2d 69 64 20 ;; " -run-id
74e0: 22 20 28 6f 72 20 72 75 6e 2d 69 64 20 22 6d 61 " (or run-id "ma
74f0: 69 6e 22 29 20 3b 3b 20 4e 4f 2c 20 77 65 20 64 in") ;; NO, we d
7500: 6f 20 4e 4f 54 20 77 61 6e 74 20 74 6f 20 68 61 o NOT want to ha
7510: 76 65 20 72 75 6e 20 69 64 20 61 73 20 70 61 72 ve run id as par
7520: 74 20 6f 66 20 74 68 69 73 0a 09 09 09 20 20 20 t of this....
7530: 20 20 22 20 2d 64 62 20 22 20 20 64 62 66 6e 61 " -db " dbfna
7540: 6d 65 20 3b 3b 20 28 64 62 6d 6f 64 3a 72 75 6e me ;; (dbmod:run
7550: 2d 69 64 2d 3e 64 62 66 6e 61 6d 65 20 72 75 6e -id->dbfname run
7560: 2d 69 64 29 0a 09 09 09 20 20 20 20 20 22 20 22 -id).... " "
7570: 20 70 72 6f 66 69 6c 65 2d 6d 6f 64 65 0a 09 09 profile-mode...
7580: 09 20 20 20 20 20 29 29 29 20 3b 3b 20 28 63 6f . ))) ;; (co
7590: 6e 63 20 22 20 3e 3e 20 22 20 6c 6f 67 66 69 6c nc " >> " logfil
75a0: 65 20 22 20 32 3e 26 31 20 26 22 29 29 29 29 29 e " 2>&1 &")))))
75b0: 0a 09 20 20 20 20 3b 3b 20 77 65 20 77 61 6e 74 .. ;; we want
75c0: 20 74 68 65 20 72 65 6d 6f 74 65 20 73 65 72 76 the remote serv
75d0: 65 72 20 74 6f 20 73 74 61 72 74 20 69 6e 20 2a er to start in *
75e0: 74 6f 70 70 61 74 68 2a 20 73 6f 20 70 75 73 68 toppath* so push
75f0: 20 74 68 65 72 65 0a 09 20 20 20 20 3b 3b 20 28 there.. ;; (
7600: 70 75 73 68 2d 64 69 72 65 63 74 6f 72 79 20 61 push-directory a
7610: 72 65 61 70 61 74 68 29 20 3b 3b 20 75 73 65 20 reapath) ;; use
7620: 63 64 20 69 6e 20 74 68 65 20 63 6f 6d 6d 61 6e cd in the comman
7630: 64 20 6c 69 6e 65 20 69 6e 73 74 65 61 64 0a 09 d line instead..
7640: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7650: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
7660: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 54 72 79 port* "INFO: Try
7670: 69 6e 67 20 74 6f 20 73 74 61 72 74 20 73 65 72 ing to start ser
7680: 76 65 72 20 69 6e 20 74 63 70 20 6d 6f 64 65 20 ver in tcp mode
7690: 28 22 20 63 6d 64 6c 6e 20 22 29 20 61 74 20 22 (" cmdln ") at "
76a0: 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 (common:human-ti
76b0: 6d 65 29 22 20 66 6f 72 20 22 61 72 65 61 70 61 me)" for "areapa
76c0: 74 68 29 0a 09 20 20 20 20 3b 3b 20 28 64 65 62 th).. ;; (deb
76d0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
76e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
76f0: 4e 46 4f 3a 20 73 74 61 72 74 69 6e 67 20 73 65 NFO: starting se
7700: 72 76 65 72 20 61 74 20 22 20 28 63 6f 6d 6d 6f rver at " (commo
7710: 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 29 0a 09 n:human-time))..
7720: 20 20 20 20 28 73 65 74 65 6e 76 20 22 4e 42 46 (setenv "NBF
7730: 41 4b 45 5f 51 55 49 45 54 22 20 22 79 65 73 22 AKE_QUIET" "yes"
7740: 29 20 3b 3b 20 42 55 47 3a 20 63 68 61 6e 67 65 ) ;; BUG: change
7750: 20 74 6f 20 77 69 74 68 2d 65 6e 76 69 72 6f 6e to with-environ
7760: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 2e 2e ment-variable ..
7770: 2e 0a 09 20 20 20 20 28 73 65 74 65 6e 76 20 22 ... (setenv "
7780: 4e 42 46 41 4b 45 5f 4c 4f 47 22 20 6c 6f 67 66 NBFAKE_LOG" logf
7790: 69 6c 65 29 0a 09 20 20 20 20 28 73 79 73 74 65 ile).. (syste
77a0: 6d 20 28 63 6f 6e 63 20 22 63 64 20 22 61 72 65 m (conc "cd "are
77b0: 61 70 61 74 68 22 20 3b 20 6e 62 66 61 6b 65 20 apath" ; nbfake
77c0: 22 20 63 6d 64 6c 6e 29 29 0a 09 20 20 20 20 28 " cmdln)).. (
77d0: 75 6e 73 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 unsetenv "NBFAKE
77e0: 5f 51 55 49 45 54 22 29 0a 09 20 20 20 20 28 75 _QUIET").. (u
77f0: 6e 73 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 5f nsetenv "NBFAKE_
7800: 4c 4f 47 22 29 0a 09 20 20 20 20 3b 3b 28 70 6f LOG").. ;;(po
7810: 70 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 20 20 p-directory)..
7820: 20 20 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))..;;=====
7830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7870: 3d 0a 3b 3b 20 74 63 70 20 63 6f 6e 6e 65 63 74 =.;; tcp connect
7880: 69 6f 6e 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d ion stuff.;;====
7890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78d0: 3d 3d 0a 0a 3b 3b 20 66 69 6e 64 20 61 20 70 6f ==..;; find a po
78e0: 72 74 20 61 6e 64 20 73 74 61 72 74 20 74 63 70 rt and start tcp
78f0: 2d 73 65 72 76 65 72 2e 20 54 68 69 73 20 6f 6e -server. This on
7900: 6c 79 20 73 74 61 72 74 73 20 74 68 65 20 74 63 ly starts the tc
7910: 70 20 70 6f 72 74 69 6f 6e 20 6f 66 0a 3b 3b 20 p portion of.;;
7920: 74 68 65 20 73 65 72 76 65 72 2c 20 6c 6f 6f 6b the server, look
7930: 20 61 74 20 28 74 74 3a 73 74 61 72 74 2d 73 65 at (tt:start-se
7940: 72 76 65 72 20 2e 2e 2e 29 20 61 62 6f 76 65 20 rver ...) above
7950: 66 6f 72 20 74 68 65 20 65 6e 74 72 79 20 70 6f for the entry po
7960: 69 6e 74 0a 3b 3b 20 66 6f 72 20 74 68 65 20 65 int.;; for the e
7970: 6e 74 69 72 65 20 73 65 72 76 65 72 20 73 79 73 ntire server sys
7980: 74 65 6d 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 tem.;;.(define (
7990: 74 74 3a 73 74 61 72 74 2d 74 63 70 2d 73 65 72 tt:start-tcp-ser
79a0: 76 65 72 20 74 74 64 61 74 29 0a 20 20 28 73 65 ver ttdat). (se
79b0: 74 75 70 2d 6c 69 73 74 65 6e 65 72 2d 70 6f 72 tup-listener-por
79c0: 74 6c 6f 67 67 65 72 20 74 74 64 61 74 29 20 3b tlogger ttdat) ;
79d0: 3b 20 73 65 74 20 75 70 20 74 63 70 2d 6c 69 73 ; set up tcp-lis
79e0: 74 65 6e 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 tener. (let* ((
79f0: 73 6f 63 6b 65 74 20 20 20 28 74 74 2d 73 6f 63 socket (tt-soc
7a00: 6b 65 74 20 20 74 74 64 61 74 29 29 0a 09 20 28 ket ttdat)).. (
7a10: 68 61 6e 64 6c 65 72 20 20 28 74 74 2d 68 61 6e handler (tt-han
7a20: 64 6c 65 72 20 74 74 64 61 74 29 29 20 3b 3b 20 dler ttdat)) ;;
7a30: 74 68 65 20 68 61 6e 64 6c 65 72 20 63 6f 6d 65 the handler come
7a40: 73 20 66 72 6f 6d 20 6f 75 72 20 63 6c 69 65 6e s from our clien
7a50: 74 20 73 65 74 74 69 6e 67 20 61 20 68 61 6e 64 t setting a hand
7a60: 6c 65 72 20 66 75 6e 63 74 69 6f 6e 0a 09 20 28 ler function.. (
7a70: 68 61 6e 64 6c 65 72 2d 70 72 6f 63 20 28 6c 61 handler-proc (la
7a80: 6d 62 64 61 20 28 29 0a 09 09 09 20 28 6c 65 74 mbda ().... (let
7a90: 2a 20 28 28 69 6e 64 61 74 20 20 20 20 20 20 20 * ((indat
7aa0: 20 20 28 64 65 73 65 72 69 61 6c 69 7a 65 29 29 (deserialize))
7ab0: 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 3a 20 28 ;; could use: (
7ac0: 74 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 thread-terminate
7ad0: 21 20 28 63 75 72 72 65 6e 74 2d 74 68 72 65 61 ! (current-threa
7ae0: 64 29 29 0a 09 09 09 09 28 72 65 73 75 6c 74 20 d)).....(result
7af0: 20 20 20 20 20 20 20 23 66 29 0a 09 09 09 09 28 #f).....(
7b00: 65 78 6e 2d 72 65 73 75 6c 74 20 20 20 20 23 66 exn-result #f
7b10: 29 0a 09 09 09 09 28 73 74 64 6f 75 74 2d 72 65 ).....(stdout-re
7b20: 73 75 6c 74 20 28 77 69 74 68 2d 6f 75 74 70 75 sult (with-outpu
7b30: 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 09 09 09 09 t-to-string.....
7b40: 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 .. (lambda ()...
7b50: 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 72 65 .... (let ((re
7b60: 73 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 s (handle-except
7b70: 69 6f 6e 73 0a 09 09 09 09 09 09 09 20 20 20 20 ions........
7b80: 20 20 20 65 78 6e 0a 09 09 09 09 09 09 09 20 20 exn........
7b90: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 65 72 72 (let* ((err
7ba0: 64 61 74 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e dat (condition->
7bb0: 6c 69 73 74 20 65 78 6e 29 29 29 0a 09 09 09 09 list exn))).....
7bc0: 09 09 09 09 20 28 73 65 74 21 20 65 78 6e 2d 72 .... (set! exn-r
7bd0: 65 73 75 6c 74 20 65 72 72 64 61 74 29 0a 09 09 esult errdat)...
7be0: 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 ...... (debug:pr
7bf0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
7c00: 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
7c10: 20 68 61 6e 64 6c 65 72 20 65 78 63 65 70 74 69 handler excepti
7c20: 6f 6e 2c 20 74 68 65 73 65 20 61 72 65 20 62 61 on, these are ba
7c30: 64 2c 20 77 69 6c 6c 20 65 78 69 74 20 69 6e 20 d, will exit in
7c40: 66 69 76 65 20 73 65 63 6f 6e 64 73 2e 22 29 0a five seconds.").
7c50: 09 09 09 09 09 09 09 09 20 28 70 70 20 65 72 72 ........ (pp err
7c60: 64 61 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 dat *default-log
7c70: 2d 70 6f 72 74 2a 29 0a 09 09 09 09 09 09 09 09 -port*).........
7c80: 20 3b 3b 20 74 68 65 73 65 20 61 72 65 20 61 6c ;; these are al
7c90: 77 61 79 73 20 62 61 64 2c 20 73 65 74 20 75 70 ways bad, set up
7ca0: 20 61 6e 20 65 78 69 74 20 74 68 72 65 61 64 0a an exit thread.
7cb0: 09 09 09 09 09 09 09 09 20 28 74 68 72 65 61 64 ........ (thread
7cc0: 2d 73 74 61 72 74 21 20 28 6d 61 6b 65 2d 74 68 -start! (make-th
7cd0: 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a read (lambda ().
7ce0: 09 09 09 09 09 09 09 20 20 20 20 20 20 09 09 09 ....... ...
7cf0: 09 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d . (thread-
7d00: 73 6c 65 65 70 21 20 35 29 0a 09 09 09 09 09 09 sleep! 5).......
7d10: 09 20 20 20 20 20 20 09 09 09 09 20 20 20 20 20 . ....
7d20: 20 20 28 65 78 69 74 29 29 29 29 0a 09 09 09 09 (exit)))).....
7d30: 09 09 09 20 20 20 20 20 20 20 23 66 29 0a 09 09 ... #f)...
7d40: 09 09 09 09 09 09 28 68 61 6e 64 6c 65 72 20 69 ......(handler i
7d50: 6e 64 61 74 29 20 3b 3b 20 74 68 69 73 20 69 73 ndat) ;; this is
7d60: 20 74 68 65 20 70 72 6f 63 20 62 65 69 6e 67 20 the proc being
7d70: 63 61 6c 6c 65 64 20 62 79 20 74 68 65 20 72 65 called by the re
7d80: 6d 6f 74 65 20 63 6c 69 65 6e 74 0a 09 09 09 09 mote client.....
7d90: 09 09 09 09 29 29 29 0a 09 09 09 09 09 09 20 20 ....))).......
7da0: 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 (set! result
7db0: 72 65 73 29 29 29 29 29 0a 09 09 09 09 28 66 75 res))))).....(fu
7dc0: 6c 6c 2d 72 65 73 75 6c 74 20 20 20 20 28 6c 69 ll-result (li
7dd0: 73 74 20 72 65 73 75 6c 74 20 65 78 6e 2d 72 65 st result exn-re
7de0: 73 75 6c 74 20 28 69 66 20 28 65 71 75 61 6c 3f sult (if (equal?
7df0: 20 73 74 64 6f 75 74 2d 72 65 73 75 6c 74 20 22 stdout-result "
7e00: 22 29 20 23 66 20 73 74 64 6f 75 74 2d 72 65 73 ") #f stdout-res
7e10: 75 6c 74 29 29 29 29 0a 09 09 09 20 20 20 28 68 ult)))).... (h
7e20: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
7e30: 0a 09 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 .... exn..
7e40: 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 .. (begin...
7e50: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
7e60: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
7e70: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 69 61 log-port* "Seria
7e80: 6c 69 7a 61 74 69 6f 6e 20 66 61 69 6c 75 72 65 lization failure
7e90: 2e 20 66 75 6c 6c 2d 72 65 73 75 6c 74 3d 22 66 . full-result="f
7ea0: 75 6c 6c 2d 72 65 73 75 6c 74 29 0a 09 09 09 20 ull-result)....
7eb0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 (thread-st
7ec0: 61 72 74 21 20 28 6d 61 6b 65 2d 74 68 72 65 61 art! (make-threa
7ed0: 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 d (lambda ()....
7ee0: 09 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 .... (thread
7ef0: 2d 73 6c 65 65 70 21 20 35 29 0a 09 09 09 09 09 -sleep! 5)......
7f00: 09 09 20 20 20 20 20 28 65 78 69 74 29 29 29 29 .. (exit))))
7f10: 29 20 20 20 20 3b 3b 20 28 73 65 72 69 61 6c 69 ) ;; (seriali
7f20: 7a 65 20 27 28 23 66 20 23 66 20 23 66 29 29 20 ze '(#f #f #f))
7f30: 3b 3b 20 64 6f 65 73 6e 27 74 20 77 6f 72 6b 20 ;; doesn't work
7f40: 2d 20 74 68 65 20 66 69 72 73 74 20 63 61 6c 6c - the first call
7f50: 20 74 6f 20 73 65 72 69 61 6c 69 7a 65 20 63 61 to serialize ca
7f60: 75 73 65 64 20 66 61 69 6c 75 72 65 0a 09 09 09 used failure....
7f70: 20 20 20 20 20 28 73 65 72 69 61 6c 69 7a 65 20 (serialize
7f80: 66 75 6c 6c 2d 72 65 73 75 6c 74 29 29 29 29 29 full-result)))))
7f90: 29 0a 20 20 20 20 28 28 6d 61 6b 65 2d 74 63 70 ). ((make-tcp
7fa0: 2d 73 65 72 76 65 72 20 73 6f 63 6b 65 74 20 68 -server socket h
7fb0: 61 6e 64 6c 65 72 2d 70 72 6f 63 29 0a 20 20 20 andler-proc).
7fc0: 20 20 23 66 20 3b 3b 20 79 65 73 2c 20 73 65 6e #f ;; yes, sen
7fd0: 64 20 65 72 72 6f 72 20 6d 65 73 73 61 67 65 73 d error messages
7fe0: 20 74 6f 20 73 74 64 2d 65 72 72 0a 20 20 20 20 to std-err.
7ff0: 20 29 29 29 0a 0a 3b 3b 20 63 72 65 61 74 65 20 )))..;; create
8000: 61 20 74 63 70 20 6c 69 73 74 65 6e 65 72 20 61 a tcp listener a
8010: 6e 64 20 72 65 74 75 72 6e 20 61 20 70 6f 70 75 nd return a popu
8020: 6c 61 74 65 64 20 75 64 61 74 20 73 74 72 75 63 lated udat struc
8030: 74 20 77 69 74 68 0a 3b 3b 20 6d 79 20 70 6f 72 t with.;; my por
8040: 74 2c 20 61 64 64 72 65 73 73 2c 20 68 6f 73 74 t, address, host
8050: 6e 61 6d 65 2c 20 70 69 64 20 65 74 63 2e 0a 3b name, pid etc..;
8060: 3b 20 72 65 74 75 72 6e 20 23 66 20 69 66 20 66 ; return #f if f
8070: 61 69 6c 20 74 6f 20 66 69 6e 64 20 61 20 70 6f ail to find a po
8080: 72 74 20 74 6f 20 61 6c 6c 6f 63 61 74 65 2e 0a rt to allocate..
8090: 3b 3b 0a 3b 3b 20 20 69 66 20 75 64 61 74 61 2d ;;.;; if udata-
80a0: 69 6e 20 69 73 20 23 66 20 63 72 65 61 74 65 20 in is #f create
80b0: 74 68 65 20 72 65 63 6f 72 64 0a 3b 3b 20 20 69 the record.;; i
80c0: 66 20 74 68 65 72 65 20 69 73 20 61 6c 72 65 61 f there is alrea
80d0: 64 79 20 61 20 73 65 72 76 2d 6c 69 73 74 65 6e dy a serv-listen
80e0: 65 72 20 72 65 74 75 72 6e 20 74 68 65 20 75 64 er return the ud
80f0: 61 74 61 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e ata.;;.;; (defin
8100: 65 20 28 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 e (setup-listene
8110: 72 20 75 63 6f 6e 6e 20 23 21 6f 70 74 69 6f 6e r uconn #!option
8120: 61 6c 20 28 70 6f 72 74 20 34 32 34 32 29 29 0a al (port 4242)).
8130: 3b 3b 20 20 20 28 61 73 73 65 72 74 20 28 74 74 ;; (assert (tt
8140: 3f 20 75 63 6f 6e 6e 29 20 22 46 41 54 41 4c 3a ? uconn) "FATAL:
8150: 20 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 setup-listener
8160: 63 61 6c 6c 65 64 20 77 69 74 68 20 77 72 6f 6e called with wron
8170: 67 20 73 74 72 75 63 74 20 22 75 63 6f 6e 6e 29 g struct "uconn)
8180: 0a 3b 3b 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 .;; (handle-ex
8190: 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 20 65 ceptions.;; e
81a0: 78 6e 0a 3b 3b 20 20 20 20 28 69 66 20 28 3c 20 xn.;; (if (<
81b0: 70 6f 72 74 20 36 35 35 33 35 29 0a 3b 3b 20 20 port 65535).;;
81c0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 (begin.;;
81d0: 09 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 . (thread-sleep!
81e0: 20 30 2e 32 35 29 0a 3b 3b 20 09 20 28 73 65 74 0.25).;; . (set
81f0: 75 70 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e up-listener ucon
8200: 6e 20 28 2b 20 70 6f 72 74 20 31 29 29 29 0a 3b n (+ port 1))).;
8210: 3b 20 20 20 20 20 20 20 20 23 66 29 0a 3b 3b 20 ; #f).;;
8220: 20 20 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 74 (connect-list
8230: 65 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 29 ener uconn port)
8240: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 ))..(define (set
8250: 75 70 2d 6c 69 73 74 65 6e 65 72 2d 70 6f 72 74 up-listener-port
8260: 6c 6f 67 67 65 72 20 75 63 6f 6e 6e 29 0a 20 20 logger uconn).
8270: 28 6c 65 74 20 28 28 70 6f 72 74 20 28 70 6f 72 (let ((port (por
8280: 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e tlogger:open-run
8290: 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 -close portlogge
82a0: 72 3a 66 69 6e 64 2d 70 6f 72 74 29 29 29 0a 20 r:find-port))).
82b0: 20 20 20 28 61 73 73 65 72 74 20 28 74 74 3f 20 (assert (tt?
82c0: 75 63 6f 6e 6e 29 20 22 46 41 54 41 4c 3a 20 73 uconn) "FATAL: s
82d0: 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 63 61 etup-listener ca
82e0: 6c 6c 65 64 20 77 69 74 68 20 77 72 6f 6e 67 20 lled with wrong
82f0: 73 74 72 75 63 74 20 22 75 63 6f 6e 6e 29 0a 20 struct "uconn).
8300: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
8310: 74 69 6f 6e 73 0a 09 65 78 6e 0a 20 20 20 20 20 tions..exn.
8320: 20 28 69 66 20 28 3c 20 70 6f 72 74 20 36 35 35 (if (< port 655
8330: 33 35 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 35).. (begin..
8340: 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f (portlogger:o
8350: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f pen-run-close po
8360: 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d 66 61 69 rtlogger:set-fai
8370: 6c 65 64 20 70 6f 72 74 29 0a 09 20 20 20 20 28 led port).. (
8380: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
8390: 32 35 29 0a 09 20 20 20 20 28 73 65 74 75 70 2d 25).. (setup-
83a0: 6c 69 73 74 65 6e 65 72 2d 70 6f 72 74 6c 6f 67 listener-portlog
83b0: 67 65 72 20 75 63 6f 6e 6e 29 29 0a 09 20 20 23 ger uconn)).. #
83c0: 66 29 0a 20 20 20 20 20 20 28 63 6f 6e 6e 65 63 f). (connec
83d0: 74 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e 6e t-listener uconn
83e0: 20 70 6f 72 74 29 29 29 29 0a 0a 28 64 65 66 69 port))))..(defi
83f0: 6e 65 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 74 ne (connect-list
8400: 65 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 29 ener uconn port)
8410: 0a 20 20 3b 3b 20 28 74 63 70 2d 6c 69 73 74 65 . ;; (tcp-liste
8420: 6e 65 72 2d 73 6f 63 6b 65 74 20 4c 49 53 54 45 ner-socket LISTE
8430: 4e 45 52 29 28 73 6f 63 6b 65 74 2d 6e 61 6d 65 NER)(socket-name
8440: 20 73 6f 29 0a 20 20 3b 3b 20 73 6f 63 6b 61 64 so). ;; sockad
8450: 64 72 2d 61 64 64 72 65 73 73 2c 20 73 6f 63 6b dr-address, sock
8460: 61 64 64 72 2d 70 6f 72 74 2c 20 73 6f 63 6b 61 addr-port, socka
8470: 64 64 72 2d 3e 73 74 72 69 6e 67 0a 20 20 28 6c ddr->string. (l
8480: 65 74 2a 20 28 28 74 6c 73 6e 20 28 74 63 70 2d et* ((tlsn (tcp-
8490: 6c 69 73 74 65 6e 20 70 6f 72 74 20 31 30 30 30 listen port 1000
84a0: 30 20 23 66 29 29 20 3b 3b 20 28 74 63 70 2d 6c 0 #f)) ;; (tcp-l
84b0: 69 73 74 65 6e 20 54 43 50 50 4f 52 54 20 5b 42 isten TCPPORT [B
84c0: 41 43 4b 4c 4f 47 20 5b 48 4f 53 54 5d 5d 29 0a ACKLOG [HOST]]).
84d0: 09 20 28 61 64 64 72 20 20 28 74 74 3a 67 65 74 . (addr (tt:get
84e0: 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 -best-guess-addr
84f0: 65 73 73 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 ess (get-host-na
8500: 6d 65 29 29 29 29 20 3b 3b 20 28 67 65 74 2d 6d me)))) ;; (get-m
8510: 79 2d 62 65 73 74 2d 61 64 64 72 65 73 73 29 29 y-best-address))
8520: 29 20 3b 3b 20 28 68 6f 73 74 69 6e 66 6f 2d 61 ) ;; (hostinfo-a
8530: 64 64 72 65 73 73 65 73 20 28 68 6f 73 74 2d 69 ddresses (host-i
8540: 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 63 75 72 72 nformation (curr
8550: 65 6e 74 2d 68 6f 73 74 6e 61 6d 65 29 29 29 0a ent-hostname))).
8560: 20 20 20 20 28 74 74 2d 70 6f 72 74 2d 73 65 74 (tt-port-set
8570: 21 20 20 20 20 20 20 75 63 6f 6e 6e 20 70 6f 72 ! uconn por
8580: 74 29 0a 20 20 20 20 28 74 74 2d 68 6f 73 74 2d t). (tt-host-
8590: 73 65 74 21 20 20 20 20 20 20 75 63 6f 6e 6e 20 set! uconn
85a0: 61 64 64 72 29 0a 20 20 20 20 28 74 74 2d 68 6f addr). (tt-ho
85b0: 73 74 2d 70 6f 72 74 2d 73 65 74 21 20 75 63 6f st-port-set! uco
85c0: 6e 6e 20 28 63 6f 6e 63 20 61 64 64 72 22 3a 22 nn (conc addr":"
85d0: 70 6f 72 74 29 29 0a 20 20 20 20 28 74 74 2d 73 port)). (tt-s
85e0: 6f 63 6b 65 74 2d 73 65 74 21 20 20 20 20 75 63 ocket-set! uc
85f0: 6f 6e 6e 20 74 6c 73 6e 29 0a 20 20 20 20 75 63 onn tlsn). uc
8600: 6f 6e 6e 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d onn))..;;=======
8610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8650: 3b 3b 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d ;; utils.;;=====
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: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86a0: 3d 0a 0a 3b 3b 20 47 65 6e 65 72 61 74 65 20 61 =..;; Generate a
86b0: 20 75 6e 69 71 75 65 20 73 69 67 6e 61 74 75 72 unique signatur
86c0: 65 20 66 6f 72 20 74 68 69 73 20 73 65 72 76 65 e for this serve
86d0: 72 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 6d 6b r.(define (tt:mk
86e0: 2d 73 69 67 6e 61 74 75 72 65 20 61 72 65 61 70 -signature areap
86f0: 61 74 68 29 0a 20 20 28 6d 65 73 73 61 67 65 2d ath). (message-
8700: 64 69 67 65 73 74 2d 73 74 72 69 6e 67 20 28 6d digest-string (m
8710: 64 35 2d 70 72 69 6d 69 74 69 76 65 29 20 0a 09 d5-primitive) ..
8720: 09 09 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d .. (with-output-
8730: 74 6f 2d 73 74 72 69 6e 67 0a 09 09 09 20 20 20 to-string....
8740: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 (lambda ()....
8750: 20 20 20 28 77 72 69 74 65 20 28 6c 69 73 74 20 (write (list
8760: 61 72 65 61 70 61 74 68 0a 20 20 20 20 20 20 20 areapath.
8770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8790: 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 (current-proc
87a0: 65 73 73 2d 69 64 29 0a 09 09 09 09 09 20 20 28 ess-id)...... (
87b0: 61 72 67 76 29 29 29 29 29 29 29 0a 0a 0a 28 64 argv)))))))...(d
87c0: 65 66 69 6e 65 20 28 74 74 3a 67 65 74 2d 62 65 efine (tt:get-be
87d0: 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 st-guess-address
87e0: 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 hostname). (le
87f0: 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 t ((res #f)).
8800: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
8810: 20 28 6c 61 6d 62 64 61 20 28 61 64 72 29 0a 20 (lambda (adr).
8820: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
8830: 65 71 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 65 eq? (u8vector-re
8840: 66 20 61 64 72 20 30 29 20 31 32 37 29 29 0a 09 f adr 0) 127))..
8850: 20 20 20 28 73 65 74 21 20 72 65 73 20 61 64 72 (set! res adr
8860: 29 29 29 0a 20 20 20 20 20 3b 3b 20 4e 4f 54 45 ))). ;; NOTE
8870: 3a 20 54 68 69 73 20 63 61 6e 20 66 61 69 6c 20 : This can fail
8880: 77 68 65 6e 20 74 68 65 72 65 20 69 73 20 6e 6f when there is no
8890: 20 6d 65 6e 74 69 6f 6e 20 6f 66 20 74 68 65 20 mention of the
88a0: 68 6f 73 74 20 69 6e 20 2f 65 74 63 2f 68 6f 73 host in /etc/hos
88b0: 74 73 2e 20 46 49 58 4d 45 0a 20 20 20 20 20 28 ts. FIXME. (
88c0: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f vector->list (ho
88d0: 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 stinfo-addresses
88e0: 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 (hostname->host
88f0: 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 29 info hostname)))
8900: 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e ). (string-in
8910: 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 20 20 tersperse .
8920: 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 (map number->str
8930: 69 6e 67 0a 09 20 20 28 75 38 76 65 63 74 6f 72 ing.. (u8vector
8940: 2d 3e 6c 69 73 74 0a 09 20 20 20 28 69 66 20 72 ->list.. (if r
8950: 65 73 20 72 65 73 20 28 68 6f 73 74 6e 61 6d 65 es res (hostname
8960: 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 ->ip hostname)))
8970: 29 20 22 2e 22 29 29 29 0a 0a 28 64 65 66 69 6e ) ".")))..(defin
8980: 65 20 28 74 74 3a 67 65 74 2d 73 65 72 76 69 6e e (tt:get-servin
8990: 66 6f 2d 64 69 72 20 61 72 65 61 70 61 74 68 29 fo-dir areapath)
89a0: 0a 20 20 28 6c 65 74 2a 20 28 28 73 70 61 74 68 . (let* ((spath
89b0: 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 22 (conc areapath"
89c0: 2f 2e 73 65 72 76 69 6e 66 6f 22 29 29 29 0a 20 /.servinfo"))).
89d0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c (if (not (fil
89e0: 65 2d 65 78 69 73 74 73 3f 20 73 70 61 74 68 29 e-exists? spath)
89f0: 29 0a 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 )..(create-direc
8a00: 74 6f 72 79 20 73 70 61 74 68 20 23 74 29 29 0a tory spath #t)).
8a10: 20 20 20 20 73 70 61 74 68 29 29 0a 0a 3b 3b 3d spath))..;;=
8a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a60: 3d 3d 3d 3d 3d 0a 3b 3b 20 6e 65 74 77 6f 72 6b =====.;; network
8a70: 20 75 74 69 6c 69 74 69 65 73 0a 3b 3b 3d 3d 3d utilities.;;===
8a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ac0: 3d 3d 3d 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 4c 6f ===..;; NOTE: Lo
8ad0: 6f 6b 20 61 74 20 61 64 64 72 65 73 73 2d 69 6e ok at address-in
8ae0: 66 6f 20 65 67 67 20 61 73 20 61 6c 74 65 72 6e fo egg as altern
8af0: 61 74 69 76 65 20 74 6f 20 73 6f 6d 65 20 6f 66 ative to some of
8b00: 20 74 68 69 73 0a 0a 28 64 65 66 69 6e 65 20 28 this..(define (
8b10: 72 61 74 65 2d 69 70 20 69 70 61 64 64 72 29 0a rate-ip ipaddr).
8b20: 20 20 28 72 65 67 65 78 2d 63 61 73 65 20 69 70 (regex-case ip
8b30: 61 64 64 72 0a 20 20 20 20 28 20 22 5e 31 32 37 addr. ( "^127
8b40: 5c 5c 2e 2e 2a 22 20 5f 20 30 20 29 0a 20 20 20 \\..*" _ 0 ).
8b50: 20 28 20 22 5e 28 31 30 5c 5c 2e 30 7c 31 39 32 ( "^(10\\.0|192
8b60: 5c 5c 2e 31 36 38 29 5c 5c 2e 2e 2a 22 20 5f 20 \\.168)\\..*" _
8b70: 31 20 29 0a 20 20 20 20 28 20 65 6c 73 65 20 32 1 ). ( else 2
8b80: 20 29 20 29 29 0a 0a 3b 3b 20 43 68 61 6e 67 65 ) ))..;; Change
8b90: 20 74 68 69 73 20 74 6f 20 62 69 61 73 20 66 6f this to bias fo
8ba0: 72 20 61 64 64 72 65 73 73 65 73 20 77 69 74 68 r addresses with
8bb0: 20 61 20 72 65 61 73 6f 6e 61 62 6c 65 20 62 72 a reasonable br
8bc0: 6f 61 64 63 61 73 74 20 76 61 6c 75 65 3f 0a 3b oadcast value?.;
8bd0: 3b 0a 28 64 65 66 69 6e 65 20 28 69 70 2d 70 72 ;.(define (ip-pr
8be0: 65 66 2d 6c 65 73 73 3f 20 61 20 62 29 0a 20 20 ef-less? a b).
8bf0: 28 3e 20 28 72 61 74 65 2d 69 70 20 61 29 20 28 (> (rate-ip a) (
8c00: 72 61 74 65 2d 69 70 20 62 29 29 29 0a 0a 28 64 rate-ip b)))..(d
8c10: 65 66 69 6e 65 20 28 67 65 74 2d 6d 79 2d 62 65 efine (get-my-be
8c20: 73 74 2d 61 64 64 72 65 73 73 29 0a 20 20 28 6c st-address). (l
8c30: 65 74 20 28 28 61 6c 6c 2d 6d 79 2d 61 64 64 72 et ((all-my-addr
8c40: 65 73 73 65 73 20 28 67 65 74 2d 61 6c 6c 2d 69 esses (get-all-i
8c50: 70 73 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a ps))). (cond.
8c60: 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 61 6c 6c ((null? all
8c70: 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 0a 20 -my-addresses).
8c80: 20 20 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e (get-host-n
8c90: 61 6d 65 29 29 20 20 20 20 20 20 20 20 20 20 20 ame))
8ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
8cc0: 3b 20 6e 6f 20 69 6e 74 65 72 66 61 63 65 73 3f ; no interfaces?
8cd0: 0a 20 20 20 20 20 28 28 65 71 3f 20 28 6c 65 6e . ((eq? (len
8ce0: 67 74 68 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 gth all-my-addre
8cf0: 73 73 65 73 29 20 31 29 0a 20 20 20 20 20 20 28 sses) 1). (
8d00: 63 61 72 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 car all-my-addre
8d10: 73 73 65 73 29 29 20 20 20 20 20 20 20 20 20 20 sses))
8d20: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f ;; o
8d30: 6e 6c 79 20 6f 6e 65 20 74 6f 20 63 68 6f 6f 73 nly one to choos
8d40: 65 20 66 72 6f 6d 2c 20 6a 75 73 74 20 67 6f 20 e from, just go
8d50: 77 69 74 68 20 69 74 0a 20 20 20 20 20 28 65 6c with it. (el
8d60: 73 65 0a 20 20 20 20 20 20 28 63 61 72 20 28 73 se. (car (s
8d70: 6f 72 74 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 ort all-my-addre
8d80: 73 73 65 73 20 69 70 2d 70 72 65 66 2d 6c 65 73 sses ip-pref-les
8d90: 73 3f 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e s?))))))..(defin
8da0: 65 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 2d 73 e (get-all-ips-s
8db0: 6f 72 74 65 64 29 0a 20 20 28 73 6f 72 74 20 28 orted). (sort (
8dc0: 67 65 74 2d 61 6c 6c 2d 69 70 73 29 20 69 70 2d get-all-ips) ip-
8dd0: 70 72 65 66 2d 6c 65 73 73 3f 29 29 0a 0a 28 64 pref-less?))..(d
8de0: 65 66 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 69 efine (get-all-i
8df0: 70 73 29 0a 20 20 28 6d 61 70 20 61 64 64 72 65 ps). (map addre
8e00: 73 73 2d 69 6e 66 6f 2d 68 6f 73 74 0a 20 20 20 ss-info-host.
8e10: 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d (filter (lam
8e20: 62 64 61 20 28 78 29 0a 09 09 20 28 65 71 75 61 bda (x)... (equa
8e30: 6c 3f 20 28 61 64 64 72 65 73 73 2d 69 6e 66 6f l? (address-info
8e40: 2d 74 79 70 65 20 78 29 20 22 74 63 70 22 29 29 -type x) "tcp"))
8e50: 0a 09 20 20 20 20 20 20 20 28 61 64 64 72 65 73 .. (addres
8e60: 73 2d 69 6e 66 6f 73 20 28 67 65 74 2d 68 6f 73 s-infos (get-hos
8e70: 74 2d 6e 61 6d 65 29 29 29 29 29 0a 0a 29 0a t-name)))))..).