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 0a 28 (uses dbmod))..(
0410: 75 73 65 20 61 64 64 72 65 73 73 2d 69 6e 66 6f use address-info
0420: 29 0a 0a 28 6d 6f 64 75 6c 65 20 74 63 70 2d 74 )..(module tcp-t
0430: 72 61 6e 73 70 6f 72 74 6d 6f 64 0a 09 2a 0a 09 ransportmod..*..
0440: 0a 20 20 28 69 6d 70 6f 72 74 20 73 63 68 65 6d . (import schem
0450: 65 0a 09 20 20 28 70 72 65 66 69 78 20 73 71 6c e.. (prefix sql
0460: 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 0a 09 ite3 sqlite3:)..
0470: 20 20 63 68 69 63 6b 65 6e 0a 09 20 20 64 61 74 chicken.. dat
0480: 61 2d 73 74 72 75 63 74 75 72 65 73 0a 0a 09 20 a-structures...
0490: 20 61 64 64 72 65 73 73 2d 69 6e 66 6f 0a 09 20 address-info..
04a0: 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 directory-utils
04b0: 0a 09 20 20 65 78 74 72 61 73 0a 09 20 20 66 69 .. extras.. fi
04c0: 6c 65 73 0a 09 20 20 68 6f 73 74 69 6e 66 6f 0a les.. hostinfo.
04d0: 09 20 20 6d 61 74 63 68 61 62 6c 65 0a 09 20 20 . matchable..
04e0: 6d 64 35 0a 09 20 20 6d 65 73 73 61 67 65 2d 64 md5.. message-d
04f0: 69 67 65 73 74 0a 09 20 20 70 6f 72 74 73 0a 09 igest.. ports..
0500: 20 20 70 6f 73 69 78 0a 09 20 20 72 65 67 65 78 posix.. regex
0510: 0a 09 20 20 72 65 67 65 78 2d 63 61 73 65 0a 09 .. regex-case..
0520: 20 20 73 31 31 6e 0a 09 20 20 73 72 66 69 2d 31 s11n.. srfi-1
0530: 0a 09 20 20 73 72 66 69 2d 31 38 0a 09 20 20 73 .. srfi-18.. s
0540: 72 66 69 2d 34 0a 09 20 20 73 72 66 69 2d 36 39 rfi-4.. srfi-69
0550: 0a 09 20 20 73 74 61 63 6b 0a 09 20 20 74 79 70 .. stack.. typ
0560: 65 64 2d 72 65 63 6f 72 64 73 0a 09 20 20 74 63 ed-records.. tc
0570: 70 2d 73 65 72 76 65 72 0a 09 20 20 74 63 70 0a p-server.. tcp.
0580: 09 20 20 0a 09 20 20 64 65 62 75 67 70 72 69 6e . .. debugprin
0590: 74 0a 09 20 20 63 6f 6d 6d 6f 6e 6d 6f 64 0a 09 t.. commonmod..
05a0: 20 20 64 62 66 69 6c 65 0a 09 20 20 64 62 6d 6f dbfile.. dbmo
05b0: 64 0a 09 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d d..)..;;========
05c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05e0: 3d 3d 3d 3d 3d 3d 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 0a 3b ==============.;
0600: 3b 20 63 6c 69 65 6e 74 0a 3b 3b 3d 3d 3d 3d 3d ; client.;;=====
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 3d 3d 3d 3d ================
0630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0650: 3d 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 6b 65 =..;; (define ke
0660: 65 70 2d 61 67 65 2d 70 61 72 61 6d 20 28 6d 61 ep-age-param (ma
0670: 6b 65 2d 70 61 72 61 6d 65 74 65 72 20 31 30 29 ke-parameter 10)
0680: 29 20 3b 3b 20 71 69 66 20 66 69 6c 65 20 61 67 ) ;; qif file ag
0690: 65 2c 20 69 66 20 6f 76 65 72 20 6d 6f 76 65 20 e, if over move
06a0: 74 6f 20 61 74 74 69 63 0a 0a 3b 3b 20 55 73 65 to attic..;; Use
06b0: 64 20 4f 4e 4c 59 20 66 6f 72 20 63 6c 69 65 6e d ONLY for clien
06c0: 74 0a 3b 3b 0a 28 64 65 66 73 74 72 75 63 74 20 t.;;.(defstruct
06d0: 74 74 2d 63 6f 6e 6e 0a 20 20 68 6f 73 74 0a 20 tt-conn. host.
06e0: 20 70 6f 72 74 0a 20 20 68 6f 73 74 2d 70 6f 72 port. host-por
06f0: 74 0a 20 20 64 62 66 6e 61 6d 65 0a 20 20 73 65 t. dbfname. se
0700: 72 76 65 72 2d 69 64 0a 20 20 73 65 72 76 65 72 rver-id. server
0710: 2d 73 74 61 72 74 0a 20 20 70 69 64 0a 29 0a 0a -start. pid.)..
0720: 3b 3b 20 55 73 65 64 20 66 6f 72 20 42 4f 54 48 ;; Used for BOTH
0730: 20 63 6c 69 65 6e 74 73 20 61 6e 64 20 73 65 72 clients and ser
0740: 76 65 72 73 0a 28 64 65 66 73 74 72 75 63 74 20 vers.(defstruct
0750: 74 74 0a 20 20 3b 3b 20 63 6c 69 65 6e 74 20 72 tt. ;; client r
0760: 65 6c 61 74 65 64 0a 20 20 28 63 6f 6e 6e 73 20 elated. (conns
0770: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
0780: 29 29 20 3b 3b 20 64 62 66 6e 61 6d 65 20 2d 3e )) ;; dbfname ->
0790: 20 63 6f 6e 6e 0a 0a 20 20 3b 3b 20 73 65 72 76 conn.. ;; serv
07a0: 65 72 20 72 65 6c 61 74 65 64 0a 20 20 28 61 72 er related. (ar
07b0: 65 61 70 61 74 68 20 20 20 20 20 23 66 29 0a 20 eapath #f).
07c0: 20 28 68 6f 73 74 20 20 20 20 20 20 20 20 20 23 (host #
07d0: 66 29 0a 20 20 28 70 6f 72 74 20 20 20 20 20 20 f). (port
07e0: 20 20 20 23 66 29 0a 20 20 28 63 6f 6e 6e 20 20 #f). (conn
07f0: 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 63 6c #f). (cl
0800: 65 61 6e 75 70 2d 70 72 6f 63 20 23 66 29 0a 20 eanup-proc #f).
0810: 20 28 68 61 6e 64 6c 65 72 20 20 20 20 20 20 23 (handler #
0820: 66 29 20 3b 3b 20 72 65 63 65 69 76 65 73 20 64 f) ;; receives d
0830: 61 74 61 20 61 6e 64 20 72 65 73 70 6f 6e 64 73 ata and responds
0840: 0a 20 20 28 73 6f 63 6b 65 74 20 20 20 20 20 20 . (socket
0850: 20 23 66 29 0a 20 20 28 74 68 72 65 61 64 20 20 #f). (thread
0860: 20 20 20 20 20 23 66 29 0a 20 20 28 68 6f 73 74 #f). (host
0870: 2d 70 6f 72 74 20 20 20 20 23 66 29 0a 20 20 28 -port #f). (
0880: 63 6d 64 2d 74 68 72 65 61 64 20 20 20 23 66 29 cmd-thread #f)
0890: 0a 20 20 28 72 6f 2d 6d 6f 64 65 20 20 20 20 20 . (ro-mode
08a0: 20 23 66 29 0a 20 20 28 72 6f 2d 6d 6f 64 65 2d #f). (ro-mode-
08b0: 63 68 65 63 6b 65 64 20 23 66 29 0a 20 20 28 6c checked #f). (l
08c0: 61 73 74 2d 61 63 63 65 73 73 20 20 28 63 75 72 ast-access (cur
08d0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 rent-seconds)).
08e0: 20 28 73 65 72 76 69 6e 66 2d 66 69 6c 65 20 23 (servinf-file #
08f0: 66 29 0a 20 20 28 6c 61 73 74 2d 73 65 72 76 2d f). (last-serv-
0900: 73 74 61 72 74 20 30 29 0a 20 20 29 0a 0a 28 64 start 0). )..(d
0910: 65 66 69 6e 65 20 28 74 74 3a 6d 61 6b 65 2d 72 efine (tt:make-r
0920: 65 6d 6f 74 65 20 61 72 65 61 70 61 74 68 29 0a emote areapath).
0930: 20 20 28 6d 61 6b 65 2d 74 74 20 61 72 65 61 70 (make-tt areap
0940: 61 74 68 3a 20 61 72 65 61 70 61 74 68 29 29 0a ath: areapath)).
0950: 0a 3b 3b 20 31 20 2e 2e 2e 20 6f 72 20 23 66 0a .;; 1 ... or #f.
0960: 28 64 65 66 69 6e 65 20 28 74 74 3a 76 61 6c 69 (define (tt:vali
0970: 64 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 d-run-id run-id)
0980: 0a 20 20 28 6f 72 20 28 6e 75 6d 62 65 72 3f 20 . (or (number?
0990: 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 28 6e run-id). (n
09a0: 6f 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b ot run-id)))..;;
09b0: 20 64 6f 20 61 6c 6c 20 74 68 65 20 62 75 73 79 do all the busy
09c0: 20 77 6f 72 6b 20 6f 66 20 66 69 6e 64 69 6e 67 work of finding
09d0: 20 61 6e 64 20 73 65 74 74 69 6e 67 20 75 70 20 and setting up
09e0: 63 6f 6e 6e 20 66 6f 72 0a 3b 3b 20 63 6f 6e 6e conn for.;; conn
09f0: 65 63 74 69 6e 67 20 74 6f 20 61 20 73 65 72 76 ecting to a serv
0a00: 65 72 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 er.;; .(define (
0a10: 74 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 tt:client-connec
0a20: 74 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 64 61 t-to-server ttda
0a30: 74 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 t dbfname run-id
0a40: 20 74 65 73 74 73 75 69 74 65 29 0a 20 20 28 61 testsuite). (a
0a50: 73 73 65 72 74 20 28 74 74 3a 76 61 6c 69 64 2d ssert (tt:valid-
0a60: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 20 22 run-id run-id) "
0a70: 46 41 54 41 4c 3a 20 69 6e 76 61 6c 69 64 20 72 FATAL: invalid r
0a80: 75 6e 2d 69 64 20 22 72 75 6e 2d 69 64 29 0a 20 un-id "run-id).
0a90: 20 28 6c 65 74 2a 20 28 28 63 6f 6e 6e 20 28 68 (let* ((conn (h
0aa0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
0ab0: 66 61 75 6c 74 20 28 74 74 2d 63 6f 6e 6e 73 20 fault (tt-conns
0ac0: 74 74 64 61 74 29 20 64 62 66 6e 61 6d 65 20 23 ttdat) dbfname #
0ad0: 66 29 29 0a 09 20 28 73 65 72 76 65 72 2d 73 74 f)).. (server-st
0ae0: 61 72 74 2d 70 72 6f 63 20 28 6c 61 6d 62 64 61 art-proc (lambda
0af0: 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 74 74 ().... (tt
0b00: 3a 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 2d :server-process-
0b10: 72 75 6e 0a 09 09 09 20 20 20 20 20 20 20 28 74 run.... (t
0b20: 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 61 74 t-areapath ttdat
0b30: 29 0a 09 09 09 20 20 20 20 20 20 20 74 65 73 74 ).... test
0b40: 73 75 69 74 65 20 3b 3b 20 28 64 62 66 69 6c 65 suite ;; (dbfile
0b50: 3a 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 :testsuite-name)
0b60: 0a 09 09 09 20 20 20 20 20 20 20 28 63 6f 6d 6d .... (comm
0b70: 6f 6e 3a 66 69 6e 64 2d 6c 6f 63 61 6c 2d 6d 65 on:find-local-me
0b80: 67 61 74 65 73 74 29 0a 09 09 09 20 20 20 20 20 gatest)....
0b90: 20 20 72 75 6e 2d 69 64 29 29 29 29 0a 20 20 20 run-id)))).
0ba0: 20 28 69 66 20 63 6f 6e 6e 0a 09 63 6f 6e 6e 20 (if conn..conn
0bb0: 3b 3b 20 77 65 20 61 72 65 20 61 6c 72 65 61 64 ;; we are alread
0bc0: 79 20 63 6f 6e 6e 65 63 74 65 64 20 74 6f 20 74 y connected to t
0bd0: 68 65 20 73 65 72 76 65 72 0a 09 28 6c 65 74 2a he server..(let*
0be0: 20 28 28 73 64 61 74 20 28 74 74 3a 67 65 74 2d ((sdat (tt:get-
0bf0: 63 75 72 72 65 6e 74 2d 73 65 72 76 65 72 2d 69 current-server-i
0c00: 6e 66 6f 20 74 74 64 61 74 20 64 62 66 6e 61 6d nfo ttdat dbfnam
0c10: 65 29 29 29 0a 09 20 20 28 6d 61 74 63 68 20 73 e))).. (match s
0c20: 64 61 74 0a 09 20 20 20 20 28 28 68 6f 73 74 20 dat.. ((host
0c30: 70 6f 72 74 20 73 74 61 72 74 2d 74 69 6d 65 20 port start-time
0c40: 73 65 72 76 65 72 2d 69 64 20 70 69 64 20 64 62 server-id pid db
0c50: 66 6e 61 6d 65 32 20 73 65 72 76 69 6e 66 66 69 fname2 servinffi
0c60: 6c 65 29 0a 09 20 20 20 20 20 28 61 73 73 65 72 le).. (asser
0c70: 74 20 28 65 71 75 61 6c 3f 20 64 62 66 6e 61 6d t (equal? dbfnam
0c80: 65 20 64 62 66 6e 61 6d 65 32 29 20 22 46 41 54 e dbfname2) "FAT
0c90: 41 4c 3a 20 72 65 61 64 20 73 65 72 76 65 72 20 AL: read server
0ca0: 69 6e 66 6f 20 66 72 6f 6d 20 77 72 6f 6e 67 20 info from wrong
0cb0: 66 69 6c 65 2e 22 29 0a 09 20 20 20 20 20 28 6c file.").. (l
0cc0: 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 et* ((host-port
0cd0: 28 63 6f 6e 63 20 68 6f 73 74 22 3a 22 70 6f 72 (conc host":"por
0ce0: 74 29 29 0a 09 09 20 20 20 20 28 63 6f 6e 6e 20 t))... (conn
0cf0: 28 6d 61 6b 65 2d 74 74 2d 63 6f 6e 6e 0a 09 09 (make-tt-conn...
0d00: 09 20 20 20 68 6f 73 74 3a 20 68 6f 73 74 0a 09 . host: host..
0d10: 09 09 20 20 20 70 6f 72 74 3a 20 70 6f 72 74 0a .. port: port.
0d20: 09 09 09 20 20 20 68 6f 73 74 2d 70 6f 72 74 3a ... host-port:
0d30: 20 68 6f 73 74 2d 70 6f 72 74 0a 09 09 09 20 20 host-port....
0d40: 20 64 62 66 6e 61 6d 65 3a 20 64 62 66 6e 61 6d dbfname: dbfnam
0d50: 65 0a 09 09 09 20 20 20 73 65 72 76 69 6e 66 2d e.... servinf-
0d60: 66 69 6c 65 3a 20 73 65 72 76 69 6e 66 66 69 6c file: servinffil
0d70: 65 0a 09 09 09 20 20 20 73 65 72 76 65 72 2d 69 e.... server-i
0d80: 64 3a 20 73 65 72 76 65 72 2d 69 64 0a 09 09 09 d: server-id....
0d90: 20 20 20 73 65 72 76 65 72 2d 73 74 61 72 74 3a server-start:
0da0: 20 73 74 61 72 74 2d 74 69 6d 65 0a 09 09 09 20 start-time....
0db0: 20 20 70 69 64 3a 20 70 69 64 29 29 29 0a 09 20 pid: pid)))..
0dc0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
0dd0: 65 2d 73 65 74 21 20 28 74 74 2d 63 6f 6e 6e 73 e-set! (tt-conns
0de0: 20 74 74 64 61 74 29 20 64 62 66 6e 61 6d 65 20 ttdat) dbfname
0df0: 63 6f 6e 6e 29 0a 09 20 20 20 20 20 20 20 3b 3b conn).. ;;
0e00: 20 76 65 72 69 66 79 20 77 65 20 63 61 6e 20 74 verify we can t
0e10: 61 6c 6b 20 74 6f 20 74 68 69 73 20 73 65 72 76 alk to this serv
0e20: 65 72 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 er.. (if (
0e30: 74 74 3a 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 tt:ping host por
0e40: 74 20 73 65 72 76 65 72 2d 69 64 29 0a 09 09 20 t server-id)...
0e50: 20 20 63 6f 6e 6e 0a 09 09 20 20 20 28 6c 65 74 conn... (let
0e60: 2a 20 28 28 63 75 72 72 2d 73 65 63 73 20 28 63 * ((curr-secs (c
0e70: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
0e80: 29 0a 09 09 20 20 20 20 20 3b 3b 20 72 6d 20 74 )... ;; rm t
0e90: 68 65 20 28 6c 61 73 74 20 73 65 72 76 65 72 29 he (last server)
0ea0: 20 77 6f 75 6c 64 20 67 6f 20 68 65 72 65 0a 09 would go here..
0eb0: 09 20 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 . (if (> (-
0ec0: 63 75 72 72 2d 73 65 63 73 20 28 74 74 2d 6c 61 curr-secs (tt-la
0ed0: 73 74 2d 73 65 72 76 2d 73 74 61 72 74 20 74 74 st-serv-start tt
0ee0: 64 61 74 29 29 20 31 30 29 0a 09 09 09 20 28 62 dat)) 10).... (b
0ef0: 65 67 69 6e 0a 09 09 09 20 20 20 28 74 74 2d 6c egin.... (tt-l
0f00: 61 73 74 2d 73 65 72 76 2d 73 74 61 72 74 2d 73 ast-serv-start-s
0f10: 65 74 21 20 74 74 64 61 74 20 63 75 72 72 2d 73 et! ttdat curr-s
0f20: 65 63 73 29 0a 09 09 09 20 20 20 28 73 65 72 76 ecs).... (serv
0f30: 65 72 2d 73 74 61 72 74 2d 70 72 6f 63 29 29 29 er-start-proc)))
0f40: 20 3b 3b 20 64 6f 6e 27 74 20 74 72 79 20 61 6e ;; don't try an
0f50: 64 20 73 74 61 72 74 20 73 65 72 76 65 72 20 75 d start server u
0f60: 6e 6c 65 73 73 20 33 30 20 73 65 63 20 68 61 73 nless 30 sec has
0f70: 20 67 6f 6e 65 20 62 79 20 73 69 6e 63 65 20 6c gone by since l
0f80: 61 73 74 20 61 74 74 65 6d 70 74 0a 09 09 20 20 ast attempt...
0f90: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
0fa0: 21 20 31 29 0a 09 09 20 20 20 20 20 28 74 74 3a ! 1)... (tt:
0fb0: 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 client-connect-t
0fc0: 6f 2d 73 65 72 76 65 72 20 74 74 64 61 74 20 64 o-server ttdat d
0fd0: 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 bfname run-id te
0fe0: 73 74 73 75 69 74 65 29 29 29 29 29 0a 09 20 20 stsuite)))))..
0ff0: 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 28 69 (else.. (i
1000: 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 f (> (- (current
1010: 2d 73 65 63 6f 6e 64 73 29 20 28 74 74 2d 6c 61 -seconds) (tt-la
1020: 73 74 2d 73 65 72 76 2d 73 74 61 72 74 20 74 74 st-serv-start tt
1030: 64 61 74 29 29 20 35 29 20 3b 3b 20 72 65 61 6c dat)) 5) ;; real
1040: 6c 79 20 64 6f 20 6e 6f 74 20 77 61 6e 74 20 74 ly do not want t
1050: 6f 20 73 77 61 6d 70 20 74 68 65 20 6d 61 63 68 o swamp the mach
1060: 69 6e 65 20 77 69 74 68 20 73 65 72 76 65 72 73 ine with servers
1070: 0a 09 09 20 28 62 65 67 69 6e 0a 09 09 20 20 20 ... (begin...
1080: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1090: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
10a0: 2d 70 6f 72 74 2a 20 22 4e 6f 20 73 65 72 76 65 -port* "No serve
10b0: 72 20 66 6f 75 6e 64 2e 20 53 74 61 72 74 69 6e r found. Startin
10c0: 67 20 6f 6e 65 20 66 6f 72 20 72 75 6e 2d 69 64 g one for run-id
10d0: 20 22 72 75 6e 2d 69 64 22 20 69 6e 20 64 62 66 "run-id" in dbf
10e0: 69 6c 65 20 22 64 62 66 6e 61 6d 65 29 0a 09 09 ile "dbfname)...
10f0: 20 20 20 28 73 65 72 76 65 72 2d 73 74 61 72 74 (server-start
1100: 2d 70 72 6f 63 29 0a 09 09 20 20 20 28 74 74 2d -proc)... (tt-
1110: 6c 61 73 74 2d 73 65 72 76 2d 73 74 61 72 74 2d last-serv-start-
1120: 73 65 74 21 20 74 74 64 61 74 20 28 63 75 72 72 set! ttdat (curr
1130: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a ent-seconds)))).
1140: 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c . (thread-sl
1150: 65 65 70 21 20 31 29 0a 09 20 20 20 20 20 28 74 eep! 1).. (t
1160: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
1170: 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 64 61 74 -to-server ttdat
1180: 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 dbfname run-id
1190: 74 65 73 74 73 75 69 74 65 29 29 29 29 29 29 29 testsuite)))))))
11a0: 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 74 . .(define (t
11b0: 74 3a 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 t:ping host port
11c0: 20 73 65 72 76 65 72 2d 69 64 29 0a 20 20 28 6c server-id). (l
11d0: 65 74 2a 20 20 28 28 72 65 73 20 28 74 74 3a 73 et* ((res (tt:s
11e0: 65 6e 64 2d 72 65 63 65 69 76 65 2d 64 69 72 65 end-receive-dire
11f0: 63 74 20 68 6f 73 74 20 70 6f 72 74 20 60 28 70 ct host port `(p
1200: 69 6e 67 20 23 66 20 23 66 20 23 66 29 29 29 29 ing #f #f #f))))
1210: 20 3b 3b 20 70 6c 65 61 73 65 20 73 65 6e 64 20 ;; please send
1220: 6d 65 20 79 6f 75 72 20 73 65 72 76 65 72 2d 69 me your server-i
1230: 64 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 d. ;;. ;;
1240: 6e 65 65 64 20 74 77 6f 20 74 68 72 65 61 64 73 need two threads
1250: 2c 20 6f 6e 65 20 61 20 35 20 73 65 63 6f 6e 64 , one a 5 second
1260: 20 74 69 6d 65 72 0a 20 20 20 20 3b 3b 0a 20 20 timer. ;;.
1270: 20 20 28 6d 61 74 63 68 20 72 65 73 0a 20 20 20 (match res.
1280: 20 20 20 28 28 73 74 61 74 75 73 20 65 72 72 6d ((status errm
1290: 73 67 20 72 65 73 75 6c 74 20 6d 65 74 61 29 0a sg result meta).
12a0: 20 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 (if (equa
12b0: 6c 3f 20 72 65 73 75 6c 74 20 73 65 72 76 65 72 l? result server
12c0: 2d 69 64 29 0a 09 20 20 20 28 62 65 67 69 6e 0a -id).. (begin.
12d0: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
12e0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
12f0: 67 2d 70 6f 72 74 2a 20 22 50 69 6e 67 20 74 6f g-port* "Ping to
1300: 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 20 73 "host":"port" s
1310: 75 63 63 65 73 73 66 75 6c 2e 22 29 0a 09 20 20 uccessful.")..
1320: 20 20 20 23 74 29 20 3b 3b 20 74 68 65 6e 20 77 #t) ;; then w
1330: 65 20 61 72 65 20 67 6f 6f 64 0a 09 20 20 20 28 e are good.. (
1340: 62 65 67 69 6e 0a 09 20 20 20 20 20 28 64 65 62 begin.. (deb
1350: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
1360: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
1370: 41 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 2d 69 ARNING: server-i
1380: 64 20 64 6f 65 73 20 6e 6f 74 20 6d 61 74 63 68 d does not match
1390: 2c 20 65 78 70 65 63 74 65 64 3a 20 22 73 65 72 , expected: "ser
13a0: 76 65 72 2d 69 64 22 2c 20 67 6f 74 3a 20 22 72 ver-id", got: "r
13b0: 65 73 75 6c 74 29 0a 09 20 20 20 20 20 23 66 29 esult).. #f)
13c0: 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 0a 20 )). (else.
13d0: 20 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a ;; (debug:
13e0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
13f0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 73 20 -log-port* "res
1400: 6e 6f 74 20 69 6e 20 66 6f 72 6d 20 28 73 74 61 not in form (sta
1410: 74 75 73 20 65 72 72 6d 73 67 20 72 65 73 75 6c tus errmsg resul
1420: 74 20 6d 65 74 61 29 2c 20 67 6f 74 3a 20 22 72 t meta), got: "r
1430: 65 73 29 0a 20 20 20 20 20 20 20 23 66 29 29 29 es). #f)))
1440: 29 0a 0a 3b 3b 20 63 6c 69 65 6e 74 20 73 69 64 )..;; client sid
1450: 65 20 68 61 6e 64 6c 65 72 0a 3b 3b 0a 3b 3b 28 e handler.;;.;;(
1460: 74 74 3a 68 61 6e 64 6c 65 72 20 23 3c 74 74 3e tt:handler #<tt>
1470: 20 67 65 74 2d 6b 65 79 73 20 23 66 20 28 29 20 get-keys #f ()
1480: 32 20 23 66 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 2 #f "/home/matt
1490: 2f 64 61 74 61 2f 6d 65 67 61 74 65 73 74 2f 65 /data/megatest/e
14a0: 78 74 2d 74 65 73 74 73 22 20 23 66 20 22 6d 61 xt-tests" #f "ma
14b0: 69 6e 2e 64 62 22 20 22 65 78 74 2d 74 65 73 74 in.db" "ext-test
14c0: 73 22 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 64 s" "/home/matt/d
14d0: 61 74 61 2f 6d 65 67 61 74 65 73 74 2f 62 69 6e ata/megatest/bin
14e0: 2f 2e 32 32 2e 30 34 2f 2e 2e 2f 6d 65 67 61 74 /.22.04/../megat
14f0: 65 73 74 22 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 est").;;.(define
1500: 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 (tt:handler ttd
1510: 61 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 at cmd run-id pa
1520: 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 20 rams attemptnum
1530: 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 area-dat areapat
1540: 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 h readonly-mode
1550: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
1560: 65 20 6d 74 65 78 65 29 0a 20 20 3b 3b 20 4e 4f e mtexe). ;; NO
1570: 54 45 3a 20 61 72 65 61 70 61 74 68 20 69 73 20 TE: areapath is
1580: 70 61 73 73 65 64 20 69 6e 20 61 6e 64 20 69 6e passed in and in
1590: 20 74 74 20 73 74 72 75 63 74 2e 20 57 65 27 6c tt struct. We'l
15a0: 6c 20 75 73 65 20 70 61 73 73 65 64 20 69 6e 20 l use passed in
15b0: 76 61 6c 75 65 20 66 6f 72 20 6e 6f 77 2e 0a 20 value for now..
15c0: 20 28 6c 65 74 2a 20 28 28 63 6f 6e 6e 20 28 74 (let* ((conn (t
15d0: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
15e0: 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 64 61 74 -to-server ttdat
15f0: 20 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 dbfname run-id
1600: 74 65 73 74 73 75 69 74 65 29 29 29 20 3b 3b 20 testsuite))) ;;
1610: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
1620: 64 65 66 61 75 6c 74 20 28 74 74 2d 63 6f 6e 6e default (tt-conn
1630: 73 20 74 74 64 61 74 29 20 64 62 66 6e 61 6d 65 s ttdat) dbfname
1640: 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 63 #f))). (if c
1650: 6f 6e 6e 0a 09 3b 3b 20 68 61 76 65 20 63 6f 6e onn..;; have con
1660: 6e 65 63 74 69 6f 6e 2c 20 63 61 6c 6c 20 74 68 nection, call th
1670: 65 20 73 65 72 76 65 72 0a 09 28 6c 65 74 2a 20 e server..(let*
1680: 28 28 72 65 73 20 28 74 74 3a 73 65 6e 64 2d 72 ((res (tt:send-r
1690: 65 63 65 69 76 65 20 74 74 64 61 74 20 63 6f 6e eceive ttdat con
16a0: 6e 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 n cmd run-id par
16b0: 61 6d 73 29 29 29 0a 09 20 20 3b 3b 20 72 65 73 ams))).. ;; res
16c0: 20 69 73 20 28 73 74 61 74 75 73 20 65 72 72 6d is (status errm
16d0: 73 67 20 72 65 73 75 6c 74 20 6d 65 74 61 29 0a sg result meta).
16e0: 09 20 20 28 6d 61 74 63 68 20 72 65 73 0a 09 20 . (match res..
16f0: 20 20 20 28 28 73 74 61 74 75 73 20 65 72 72 6d ((status errm
1700: 73 67 20 72 65 73 75 6c 74 20 6d 65 74 61 29 0a sg result meta).
1710: 09 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f . (if (list?
1720: 20 6d 65 74 61 29 0a 09 09 20 28 6c 65 74 2a 20 meta)... (let*
1730: 28 28 64 65 6c 61 79 2d 77 61 69 74 20 28 61 6c ((delay-wait (al
1740: 69 73 74 2d 72 65 66 20 27 64 65 6c 61 79 2d 77 ist-ref 'delay-w
1750: 61 69 74 20 6d 65 74 61 29 29 29 0a 09 09 20 20 ait meta)))...
1760: 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 (if (and (numbe
1770: 72 3f 20 64 65 6c 61 79 2d 77 61 69 74 29 0a 09 r? delay-wait)..
1780: 09 09 20 20 20 20 28 3e 20 64 65 6c 61 79 2d 77 .. (> delay-w
1790: 61 69 74 20 30 29 29 0a 09 09 20 20 20 20 20 20 ait 0))...
17a0: 20 28 62 65 67 69 6e 0a 09 09 09 20 28 64 65 62 (begin.... (deb
17b0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
17c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
17d0: 65 72 76 65 72 20 69 73 20 6c 6f 61 64 65 64 2c erver is loaded,
17e0: 20 64 65 6c 61 79 69 6e 67 20 22 64 65 6c 61 79 delaying "delay
17f0: 2d 77 61 69 74 22 20 73 65 63 6f 6e 64 73 22 29 -wait" seconds")
1800: 0a 09 09 09 20 28 74 68 72 65 61 64 2d 73 6c 65 .... (thread-sle
1810: 65 70 21 20 64 65 6c 61 79 2d 77 61 69 74 29 29 ep! delay-wait))
1820: 29 29 29 0a 09 20 20 20 20 20 28 63 61 73 65 20 ))).. (case
1830: 73 74 61 74 75 73 0a 09 20 20 20 20 20 20 20 28 status.. (
1840: 28 62 75 73 79 29 20 3b 3b 20 72 65 73 75 6c 74 (busy) ;; result
1850: 20 77 69 6c 6c 20 62 65 20 68 6f 77 20 6c 6f 6e will be how lon
1860: 67 20 74 68 65 20 73 65 72 76 65 72 20 77 61 6e g the server wan
1870: 74 73 20 79 6f 75 20 74 6f 20 64 65 6c 61 79 0a ts you to delay.
1880: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
1890: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
18a0: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 65 rt* "WARNING: se
18b0: 72 76 65 72 20 69 73 20 6f 76 65 72 6c 6f 61 64 rver is overload
18c0: 65 64 2c 20 77 69 6c 6c 20 74 72 79 20 61 67 61 ed, will try aga
18d0: 69 6e 20 69 6e 20 22 72 65 73 75 6c 74 22 20 73 in in "result" s
18e0: 65 63 6f 6e 64 73 2e 22 29 0a 09 09 28 74 68 72 econds.")...(thr
18f0: 65 61 64 2d 73 6c 65 65 70 21 20 28 69 66 20 28 ead-sleep! (if (
1900: 6e 75 6d 62 65 72 3f 20 72 65 73 75 6c 74 29 20 number? result)
1910: 72 65 73 75 6c 74 20 32 29 29 0a 09 09 28 74 74 result 2))...(tt
1920: 3a 68 61 6e 64 6c 65 72 20 20 74 74 64 61 74 20 :handler ttdat
1930: 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d cmd run-id param
1940: 73 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 s (+ attemptnum
1950: 31 29 20 61 72 65 61 2d 64 61 74 20 61 72 65 61 1) area-dat area
1960: 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f path readonly-mo
1970: 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 74 73 de dbfname tests
1980: 75 69 74 65 20 6d 74 65 78 65 29 29 0a 09 20 20 uite mtexe))..
1990: 20 20 20 20 20 28 28 6c 6f 61 64 65 64 29 0a 09 ((loaded)..
19a0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
19b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
19c0: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 65 72 t* "WARNING: ser
19d0: 76 65 72 20 69 73 20 6c 6f 61 64 65 64 2c 20 77 ver is loaded, w
19e0: 69 6c 6c 20 74 72 79 20 61 67 61 69 6e 20 69 6e ill try again in
19f0: 20 61 20 31 2f 34 20 73 65 63 6f 6e 64 2e 22 29 a 1/4 second.")
1a00: 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
1a10: 21 20 30 2e 32 35 29 0a 09 09 28 74 74 3a 68 61 ! 0.25)...(tt:ha
1a20: 6e 64 6c 65 72 20 20 74 74 64 61 74 20 63 6d 64 ndler ttdat cmd
1a30: 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 run-id params (
1a40: 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 + attemptnum 1)
1a50: 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 area-dat areapat
1a60: 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 h readonly-mode
1a70: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
1a80: 65 20 6d 74 65 78 65 29 29 0a 09 20 20 20 20 20 e mtexe))..
1a90: 20 20 28 65 6c 73 65 0a 09 09 72 65 73 75 6c 74 (else...result
1aa0: 29 29 29 0a 09 20 20 20 20 28 65 6c 73 65 0a 09 ))).. (else..
1ab0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 72 65 (if (not re
1ac0: 73 29 0a 09 09 20 28 6c 65 74 2a 20 28 28 68 6f s)... (let* ((ho
1ad0: 73 74 20 20 20 20 28 74 74 2d 63 6f 6e 6e 2d 68 st (tt-conn-h
1ae0: 6f 73 74 20 63 6f 6e 6e 29 29 0a 09 09 09 28 70 ost conn))....(p
1af0: 6f 72 74 20 20 20 20 28 74 74 2d 63 6f 6e 6e 2d ort (tt-conn-
1b00: 70 6f 72 74 20 63 6f 6e 6e 29 29 0a 09 09 09 3b port conn))....;
1b10: 3b 20 28 64 62 66 6e 61 6d 65 20 28 74 74 2d 63 ; (dbfname (tt-c
1b20: 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 20 onn-port conn))
1b30: 3b 3b 20 31 39 32 2e 31 36 38 2e 30 2e 31 32 37 ;; 192.168.0.127
1b40: 3a 34 32 34 32 2d 37 32 36 39 32 34 3a 34 2e 64 :4242-726924:4.d
1b50: 62 0a 09 09 09 28 70 69 64 20 20 20 20 20 28 74 b....(pid (t
1b60: 74 2d 63 6f 6e 6e 2d 70 69 64 20 20 63 6f 6e 6e t-conn-pid conn
1b70: 29 29 0a 09 09 09 28 73 65 72 76 69 6e 66 20 28 ))....(servinf (
1b80: 63 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f 2e conc areapath"/.
1b90: 73 65 72 76 69 6e 66 6f 2f 22 68 6f 73 74 22 3a servinfo/"host":
1ba0: 22 70 6f 72 74 22 2d 22 70 69 64 22 3a 22 64 62 "port"-"pid":"db
1bb0: 66 6e 61 6d 65 29 29 29 0a 09 09 20 20 20 28 68 fname)))... (h
1bc0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
1bd0: 74 74 2d 63 6f 6e 6e 73 20 74 74 64 61 74 29 20 tt-conns ttdat)
1be0: 64 62 66 6e 61 6d 65 20 23 66 29 0a 09 09 20 20 dbfname #f)...
1bf0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
1c00: 73 3f 20 73 65 72 76 69 6e 66 29 0a 09 09 20 20 s? servinf)...
1c10: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 (begin....
1c20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1c30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1c40: 2a 20 22 49 4e 46 4f 3a 20 63 6f 6e 6e 65 63 74 * "INFO: connect
1c50: 69 6f 6e 20 74 6f 20 73 65 72 76 65 72 20 22 68 ion to server "h
1c60: 6f 73 74 22 3a 22 70 6f 72 74 22 20 62 72 6f 6b ost":"port" brok
1c70: 65 6e 20 66 6f 72 20 22 64 62 66 6e 61 6d 65 22 en for "dbfname"
1c80: 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 , attempting to
1c90: 72 65 6d 6f 76 65 20 73 65 72 76 69 6e 66 6f 20 remove servinfo
1ca0: 66 69 6c 65 2e 22 29 0a 09 09 09 20 28 64 65 6c file.").... (del
1cb0: 65 74 65 2d 66 69 6c 65 2a 20 73 65 72 76 69 6e ete-file* servin
1cc0: 66 29 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 f))... (de
1cd0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
1ce0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1cf0: 49 4e 46 4f 3a 20 63 6f 6e 6e 65 63 74 69 6f 6e INFO: connection
1d00: 20 74 6f 20 73 65 72 76 65 72 20 22 68 6f 73 74 to server "host
1d10: 22 3a 22 70 6f 72 74 22 20 62 72 6f 6b 65 6e 20 ":"port" broken
1d20: 66 6f 72 20 22 64 62 66 6e 61 6d 65 22 2c 20 62 for "dbfname", b
1d30: 75 74 20 64 6f 20 6e 6f 74 20 73 65 65 20 73 65 ut do not see se
1d40: 72 76 69 6e 66 20 66 69 6c 65 20 22 73 65 72 76 rvinf file "serv
1d50: 69 6e 66 29 29 0a 09 09 20 20 20 28 74 74 3a 68 inf))... (tt:h
1d60: 61 6e 64 6c 65 72 20 74 74 64 61 74 20 63 6d 64 andler ttdat cmd
1d70: 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 28 run-id params (
1d80: 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 20 + attemptnum 1)
1d90: 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 area-dat areapat
1da0: 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 h readonly-mode
1db0: 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 dbfname testsuit
1dc0: 65 20 6d 74 65 78 65 29 29 0a 09 09 20 28 61 73 e mtexe))... (as
1dd0: 73 65 72 74 20 23 66 20 22 46 41 54 41 4c 3a 20 sert #f "FATAL:
1de0: 74 74 3a 68 61 6e 64 6c 65 72 20 72 65 63 65 69 tt:handler recei
1df0: 76 65 64 20 62 61 64 20 64 61 74 61 20 22 72 65 ved bad data "re
1e00: 73 29 29 29 29 29 0a 09 28 62 65 67 69 6e 0a 09 s)))))..(begin..
1e10: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
1e20: 20 31 29 20 3b 3b 20 67 69 76 65 20 69 74 20 61 1) ;; give it a
1e30: 20 72 65 73 74 20 61 6e 64 20 74 72 79 20 61 67 rest and try ag
1e40: 61 69 6e 0a 09 20 20 28 74 74 3a 68 61 6e 64 6c ain.. (tt:handl
1e50: 65 72 20 74 74 64 61 74 20 63 6d 64 20 72 75 6e er ttdat cmd run
1e60: 2d 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d -id params attem
1e70: 70 74 6e 75 6d 20 61 72 65 61 2d 64 61 74 20 61 ptnum area-dat a
1e80: 72 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 reapath readonly
1e90: 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 -mode dbfname te
1ea0: 73 74 73 75 69 74 65 20 6d 74 65 78 65 29 29 29 stsuite mtexe)))
1eb0: 29 29 0a 0a 09 3b 3b 20 6e 6f 20 63 6f 6e 6e 20 ))...;; no conn
1ec0: 79 65 74 2c 20 66 69 6e 64 20 61 6e 64 20 6f 72 yet, find and or
1ed0: 20 73 74 61 72 74 20 61 6e 64 20 66 69 6e 64 20 start and find
1ee0: 61 20 73 65 72 76 65 72 0a 3b 3b 20 09 28 6c 65 a server.;; .(le
1ef0: 74 2a 20 28 28 73 65 72 76 65 72 20 28 74 74 3a t* ((server (tt:
1f00: 66 69 6e 64 2d 73 65 72 76 65 72 20 74 74 64 61 find-server ttda
1f10: 74 20 64 62 66 6e 61 6d 65 29 29 29 0a 3b 3b 20 t dbfname))).;;
1f20: 09 20 20 28 69 66 20 73 65 72 76 65 72 0a 3b 3b . (if server.;;
1f30: 20 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
1f40: 63 6f 6e 6e 20 28 74 74 3a 63 6c 69 65 6e 74 2d conn (tt:client-
1f50: 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 65 connect-to-serve
1f60: 72 20 73 65 72 76 65 72 29 29 29 0a 3b 3b 20 09 r server))).;; .
1f70: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
1f80: 21 20 28 74 74 2d 63 6f 6e 6e 73 20 74 74 64 61 ! (tt-conns ttda
1f90: 74 29 20 64 62 66 6e 61 6d 65 20 63 6f 6e 6e 29 t) dbfname conn)
1fa0: 0a 3b 3b 20 09 09 28 74 74 3a 68 61 6e 64 6c 65 .;; ..(tt:handle
1fb0: 72 20 20 74 74 64 61 74 20 63 6d 64 20 72 75 6e r ttdat cmd run
1fc0: 2d 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d -id params attem
1fd0: 70 74 6e 75 6d 20 61 72 65 61 2d 64 61 74 20 61 ptnum area-dat a
1fe0: 72 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 reapath readonly
1ff0: 2d 6d 6f 64 65 0a 3b 3b 20 09 09 09 20 20 20 20 -mode.;; ...
2000: 20 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 dbfname testsui
2010: 74 65 20 6d 74 65 78 65 29 29 0a 3b 3b 20 09 20 te mtexe)).;; .
2020: 20 20 20 20 20 3b 3b 20 6e 6f 20 73 65 72 76 65 ;; no serve
2030: 72 2c 20 74 72 79 20 74 6f 20 73 74 61 72 74 20 r, try to start
2040: 61 20 73 65 72 76 65 72 20 70 72 6f 63 65 73 73 a server process
2050: 0a 3b 3b 20 09 20 20 20 20 20 20 28 62 65 67 69 .;; . (begi
2060: 6e 0a 3b 3b 20 09 09 28 74 74 3a 73 65 72 76 65 n.;; ..(tt:serve
2070: 72 2d 70 72 6f 63 65 73 73 2d 72 75 6e 20 61 72 r-process-run ar
2080: 65 61 70 61 74 68 20 74 65 73 74 73 75 69 74 65 eapath testsuite
2090: 20 6d 74 65 78 65 20 72 75 6e 2d 69 64 29 20 3b mtexe run-id) ;
20a0: 3b 20 20 23 21 6b 65 79 20 28 70 72 6f 66 69 6c ; #!key (profil
20b0: 65 2d 6d 6f 64 65 20 22 22 29 29 20 0a 3b 3b 20 e-mode "")) .;;
20c0: 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
20d0: 20 31 29 0a 3b 3b 20 09 09 28 74 74 3a 68 61 6e 1).;; ..(tt:han
20e0: 64 6c 65 72 20 20 74 74 64 61 74 20 63 6d 64 20 dler ttdat cmd
20f0: 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 61 74 run-id params at
2100: 74 65 6d 70 74 6e 75 6d 20 61 72 65 61 2d 64 61 temptnum area-da
2110: 74 20 61 72 65 61 70 61 74 68 0a 3b 3b 20 09 09 t areapath.;; ..
2120: 09 20 20 20 20 20 72 65 61 64 6f 6e 6c 79 2d 6d . readonly-m
2130: 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 74 ode dbfname test
2140: 73 75 69 74 65 20 6d 74 65 78 65 29 29 29 29 29 suite mtexe)))))
2150: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a ))..(define (tt:
2160: 62 69 64 2d 66 6f 72 2d 73 65 72 76 65 72 73 68 bid-for-serversh
2170: 69 70 20 72 75 6e 2d 69 64 29 0a 20 20 23 66 29 ip run-id). #f)
2180: 0a 0a 3b 3b 20 67 65 74 73 20 73 65 72 76 65 72 ..;; gets server
2190: 20 69 6e 66 6f 20 61 6e 64 20 61 70 70 65 6e 64 info and append
21a0: 73 20 70 61 74 68 20 74 6f 20 73 65 72 76 65 72 s path to server
21b0: 20 66 69 6c 65 0a 3b 3b 20 73 6f 72 74 73 20 62 file.;; sorts b
21c0: 79 20 61 67 65 2c 20 6f 6c 64 65 73 74 20 66 69 y age, oldest fi
21d0: 72 73 74 0a 3b 3b 0a 3b 3b 20 72 65 74 75 72 6e rst.;;.;; return
21e0: 73 20 6c 69 73 74 20 6f 66 20 28 68 6f 73 74 20 s list of (host
21f0: 70 6f 72 74 20 73 74 61 72 74 73 65 63 6f 6e 64 port startsecond
2200: 73 20 73 65 72 76 65 72 2d 69 64 20 73 65 72 76 s server-id serv
2210: 69 6e 66 6f 66 69 6c 65 29 0a 3b 3b 0a 28 64 65 infofile).;;.(de
2220: 66 69 6e 65 20 28 74 74 3a 67 65 74 2d 73 65 72 fine (tt:get-ser
2230: 76 65 72 2d 69 6e 66 6f 2d 73 6f 72 74 65 64 20 ver-info-sorted
2240: 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 0a 20 ttdat dbfname).
2250: 20 28 6c 65 74 2a 20 28 28 61 72 65 61 70 61 74 (let* ((areapat
2260: 68 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 74 h (tt-areapath t
2270: 74 64 61 74 29 29 0a 09 20 28 73 66 69 6c 65 73 tdat)).. (sfiles
2280: 20 20 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 (tt:find-serv
2290: 65 72 20 61 72 65 61 70 61 74 68 20 64 62 66 6e er areapath dbfn
22a0: 61 6d 65 29 29 0a 09 20 28 73 64 61 74 73 20 20 ame)).. (sdats
22b0: 20 20 28 66 69 6c 74 65 72 20 63 61 72 20 28 6d (filter car (m
22c0: 61 70 20 74 74 3a 73 65 72 76 65 72 2d 67 65 74 ap tt:server-get
22d0: 2d 69 6e 66 6f 20 73 66 69 6c 65 73 29 29 29 20 -info sfiles)))
22e0: 3b 3b 20 66 69 72 73 74 20 65 6c 65 6d 65 6e 74 ;; first element
22f0: 20 69 73 20 23 66 20 69 66 20 74 68 65 20 66 69 is #f if the fi
2300: 6c 65 20 64 69 73 61 70 70 65 61 72 65 64 20 77 le disappeared w
2310: 68 69 6c 65 20 62 65 69 6e 67 20 72 65 61 64 0a hile being read.
2320: 09 20 28 73 6f 72 74 65 64 20 20 20 28 73 6f 72 . (sorted (sor
2330: 74 20 73 64 61 74 73 20 28 6c 61 6d 62 64 61 20 t sdats (lambda
2340: 28 61 20 62 29 0a 09 09 09 09 20 28 3c 20 28 6c (a b)..... (< (l
2350: 69 73 74 2d 72 65 66 20 61 20 32 29 28 6c 69 73 ist-ref a 2)(lis
2360: 74 2d 72 65 66 20 62 20 32 29 29 29 29 29 29 0a t-ref b 2)))))).
2370: 20 20 20 20 73 6f 72 74 65 64 29 29 0a 20 20 20 sorted)).
2380: 20 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 67 65 .(define (tt:ge
2390: 74 2d 63 75 72 72 65 6e 74 2d 73 65 72 76 65 72 t-current-server
23a0: 2d 69 6e 66 6f 20 74 74 64 61 74 20 64 62 66 6e -info ttdat dbfn
23b0: 61 6d 65 29 0a 20 20 28 61 73 73 65 72 74 20 28 ame). (assert (
23c0: 74 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 61 tt-areapath ttda
23d0: 74 29 20 22 46 41 54 41 4c 3a 20 61 72 65 61 70 t) "FATAL: areap
23e0: 61 74 68 20 6e 6f 74 20 73 65 74 20 69 6e 20 74 ath not set in t
23f0: 74 64 61 74 2e 22 29 0a 20 20 3b 3b 0a 20 20 3b tdat."). ;;. ;
2400: 3b 20 54 4f 44 4f 20 2d 20 72 65 70 6c 61 63 65 ; TODO - replace
2410: 20 6d 6f 73 74 20 6f 66 20 62 65 6c 6f 77 20 77 most of below w
2420: 69 74 68 20 74 74 3b 67 65 74 2d 73 65 72 76 65 ith tt;get-serve
2430: 72 2d 69 6e 66 6f 2d 73 6f 72 74 65 64 0a 20 20 r-info-sorted.
2440: 3b 3b 0a 20 20 28 6c 65 74 2a 20 28 28 61 72 65 ;;. (let* ((are
2450: 61 70 61 74 68 20 28 74 74 2d 61 72 65 61 70 61 apath (tt-areapa
2460: 74 68 20 74 74 64 61 74 29 29 0a 09 20 28 73 66 th ttdat)).. (sf
2470: 69 6c 65 73 20 20 20 28 74 74 3a 66 69 6e 64 2d iles (tt:find-
2480: 73 65 72 76 65 72 20 61 72 65 61 70 61 74 68 20 server areapath
2490: 64 62 66 6e 61 6d 65 29 29 0a 09 20 28 73 64 61 dbfname)).. (sda
24a0: 74 73 20 20 20 20 28 66 69 6c 74 65 72 20 63 61 ts (filter ca
24b0: 72 20 28 6d 61 70 20 74 74 3a 73 65 72 76 65 72 r (map tt:server
24c0: 2d 67 65 74 2d 69 6e 66 6f 20 73 66 69 6c 65 73 -get-info sfiles
24d0: 29 29 29 20 3b 3b 20 66 69 72 73 74 20 65 6c 65 ))) ;; first ele
24e0: 6d 65 6e 74 20 69 73 20 23 66 20 69 66 20 74 68 ment is #f if th
24f0: 65 20 66 69 6c 65 20 64 69 73 61 70 70 65 61 72 e file disappear
2500: 65 64 20 77 68 69 6c 65 20 62 65 69 6e 67 20 72 ed while being r
2510: 65 61 64 0a 09 20 28 73 6f 72 74 65 64 20 20 20 ead.. (sorted
2520: 28 73 6f 72 74 20 73 64 61 74 73 20 28 6c 61 6d (sort sdats (lam
2530: 62 64 61 20 28 61 20 62 29 0a 09 09 09 09 20 28 bda (a b)..... (
2540: 3c 20 28 6c 69 73 74 2d 72 65 66 20 61 20 32 29 < (list-ref a 2)
2550: 28 6c 69 73 74 2d 72 65 66 20 62 20 32 29 29 29 (list-ref b 2)))
2560: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ))). (if (nul
2570: 6c 3f 20 73 6f 72 74 65 64 29 0a 09 23 66 20 20 l? sorted)..#f
2580: 3b 3b 20 77 65 27 6c 6c 20 77 61 6e 74 20 74 6f ;; we'll want to
2590: 20 77 61 69 74 20 75 6e 74 69 6c 20 65 78 74 72 wait until extr
25a0: 61 20 73 65 72 76 65 72 73 20 68 61 76 65 20 65 a servers have e
25b0: 78 69 74 65 64 0a 09 28 63 61 72 20 73 6f 72 74 xited..(car sort
25c0: 65 64 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ed))))..(define
25d0: 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 (tt:send-receive
25e0: 20 74 74 64 61 74 20 63 6f 6e 6e 20 63 6d 64 20 ttdat conn cmd
25f0: 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 0a 20 run-id params).
2600: 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f (let* ((host-po
2610: 72 74 20 28 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 rt (tt-conn-host
2620: 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 20 3b 3b 20 -port conn)) ;;
2630: 28 63 6f 6e 63 20 28 74 74 2d 63 6f 6e 6e 2d 68 (conc (tt-conn-h
2640: 6f 73 74 20 63 6f 6e 6e 29 22 3a 22 28 74 74 2d ost conn)":"(tt-
2650: 63 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 29 conn-port conn))
2660: 29 0a 09 20 28 68 6f 73 74 20 20 20 20 20 20 28 ).. (host (
2670: 74 74 2d 63 6f 6e 6e 2d 68 6f 73 74 20 63 6f 6e tt-conn-host con
2680: 6e 29 29 0a 09 20 28 70 6f 72 74 20 20 20 20 20 n)).. (port
2690: 20 28 74 74 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 (tt-conn-port c
26a0: 6f 6e 6e 29 29 0a 09 20 28 64 61 74 20 20 20 20 onn)).. (dat
26b0: 20 20 20 28 6c 69 73 74 20 63 6d 64 20 72 75 6e (list cmd run
26c0: 2d 69 64 20 70 61 72 61 6d 73 20 23 66 29 29 29 -id params #f)))
26d0: 20 3b 3b 20 6e 6f 20 6d 65 74 61 20 64 61 74 61 ;; no meta data
26e0: 20 79 65 74 0a 20 20 20 20 28 74 74 3a 73 65 6e yet. (tt:sen
26f0: 64 2d 72 65 63 65 69 76 65 2d 64 69 72 65 63 74 d-receive-direct
2700: 20 68 6f 73 74 20 70 6f 72 74 20 64 61 74 29 29 host port dat))
2710: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 73 )..(define (tt:s
2720: 65 6e 64 2d 72 65 63 65 69 76 65 2d 64 69 72 65 end-receive-dire
2730: 63 74 20 68 6f 73 74 20 70 6f 72 74 20 64 61 74 ct host port dat
2740: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d ). (assert (num
2750: 62 65 72 3f 20 70 6f 72 74 29 20 22 46 41 54 41 ber? port) "FATA
2760: 4c 3a 20 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 L: tt:send-recei
2770: 76 65 2d 64 69 72 65 63 74 20 63 61 6c 6c 65 64 ve-direct called
2780: 20 77 69 74 68 20 70 6f 72 74 20 6e 6f 74 20 61 with port not a
2790: 20 6e 75 6d 62 65 72 20 22 70 6f 72 74 29 0a 20 number "port).
27a0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
27b0: 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 ons. exn.
27c0: 20 20 23 66 20 3b 3b 20 41 64 64 20 63 6f 6e 64 #f ;; Add cond
27d0: 69 74 69 6f 6e 2d 63 61 73 65 20 6f 72 20 62 65 ition-case or be
27e0: 74 74 65 72 20 68 61 6e 64 6c 69 6e 67 20 68 65 tter handling he
27f0: 72 65 0a 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 re. (let-valu
2800: 65 73 20 28 28 28 69 6e 70 20 6f 75 70 29 28 74 es (((inp oup)(t
2810: 63 70 2d 63 6f 6e 6e 65 63 74 20 68 6f 73 74 20 cp-connect host
2820: 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 28 6c port))). (l
2830: 65 74 20 28 28 72 65 73 20 28 69 66 20 28 61 6e et ((res (if (an
2840: 64 20 69 6e 70 20 6f 75 70 29 0a 09 09 20 20 20 d inp oup)...
2850: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 (begin...
2860: 20 20 28 73 65 72 69 61 6c 69 7a 65 20 64 61 74 (serialize dat
2870: 20 6f 75 70 29 0a 09 09 20 20 20 20 20 20 20 28 oup)... (
2880: 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
2890: 74 20 6f 75 70 29 0a 09 09 20 20 20 20 20 20 20 t oup)...
28a0: 28 64 65 73 65 72 69 61 6c 69 7a 65 20 69 6e 70 (deserialize inp
28b0: 29 29 0a 09 09 20 20 20 20 20 29 29 29 0a 09 28 ))... )))..(
28c0: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
28d0: 20 69 6e 70 29 0a 09 72 65 73 29 29 29 29 0a 0a inp)..res))))..
28e0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
28f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 73 65 ==========.;; se
2930: 72 76 65 72 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d rver.;;=========
2940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
2980: 64 65 66 69 6e 65 20 28 74 74 3a 73 79 6e 63 2d define (tt:sync-
2990: 64 62 73 20 74 74 64 61 74 29 0a 20 20 23 66 29 dbs ttdat). #f)
29a0: 0a 0a 3b 3b 20 73 74 61 72 74 20 74 68 65 20 6c ..;; start the l
29b0: 69 73 74 65 6e 65 72 20 61 6e 64 20 73 74 61 72 istener and star
29c0: 74 20 72 65 73 70 6f 6e 64 69 6e 67 20 74 6f 20 t responding to
29d0: 72 65 71 75 65 73 74 73 0a 3b 3b 0a 3b 3b 20 4e requests.;;.;; N
29e0: 4f 54 45 3a 20 6f 72 67 61 6e 69 73 65 20 62 79 OTE: organise by
29f0: 20 64 62 66 6e 61 6d 65 2c 20 6e 6f 74 20 72 75 dbfname, not ru
2a00: 6e 2d 69 64 20 73 6f 20 77 65 20 64 6f 6e 27 74 n-id so we don't
2a10: 20 6e 65 65 64 0a 3b 3b 20 20 20 20 20 20 20 74 need.;; t
2a20: 6f 20 70 75 6c 6c 20 69 6e 20 6d 6f 72 65 20 6d o pull in more m
2a30: 6f 64 75 6c 65 73 0a 3b 3b 0a 3b 3b 20 54 68 69 odules.;;.;; Thi
2a40: 73 20 69 73 20 74 68 65 20 72 6f 75 74 69 6e 65 s is the routine
2a50: 20 63 61 6c 6c 65 64 20 69 6e 20 6d 65 67 61 74 called in megat
2a60: 65 73 74 2e 73 63 6d 20 74 6f 20 73 74 61 72 74 est.scm to start
2a70: 20 61 20 73 65 72 76 65 72 0a 3b 3b 0a 3b 3b 20 a server.;;.;;
2a80: 53 65 72 76 65 72 20 76 69 61 62 69 6c 69 74 79 Server viability
2a90: 20 69 73 20 63 68 65 63 6b 65 64 20 69 6e 20 6b is checked in k
2aa0: 65 65 70 2d 72 75 6e 6e 69 6e 67 2e 20 42 6c 69 eep-running. Bli
2ab0: 6e 64 6c 79 20 73 74 61 72 74 20 61 6e 64 20 72 ndly start and r
2ac0: 75 6e 20 68 65 72 65 2e 0a 3b 3b 0a 28 64 65 66 un here..;;.(def
2ad0: 69 6e 65 20 28 74 74 3a 73 74 61 72 74 2d 73 65 ine (tt:start-se
2ae0: 72 76 65 72 20 61 72 65 61 70 61 74 68 20 72 75 rver areapath ru
2af0: 6e 2d 69 64 20 64 62 66 6e 61 6d 65 2d 69 6e 20 n-id dbfname-in
2b00: 68 61 6e 64 6c 65 72 20 6b 65 79 73 29 0a 20 20 handler keys).
2b10: 28 61 73 73 65 72 74 20 61 72 65 61 70 61 74 68 (assert areapath
2b20: 20 22 46 41 54 41 4c 3a 20 61 72 65 61 70 61 74 "FATAL: areapat
2b30: 68 20 6e 6f 74 20 70 72 6f 76 69 64 65 64 20 66 h not provided f
2b40: 6f 72 20 74 74 3a 73 74 61 72 74 2d 73 65 72 76 or tt:start-serv
2b50: 65 72 22 29 0a 20 20 3b 3b 20 69 73 20 74 68 65 er"). ;; is the
2b60: 72 65 20 61 6c 72 65 61 64 79 20 61 20 73 65 72 re already a ser
2b70: 76 65 72 20 66 6f 72 20 74 68 69 73 20 64 62 66 ver for this dbf
2b80: 69 6c 65 3f 20 54 68 65 6e 20 65 78 69 74 2e 0a ile? Then exit..
2b90: 20 20 28 6c 65 74 2a 20 28 28 74 74 64 61 74 20 (let* ((ttdat
2ba0: 20 20 28 6d 61 6b 65 2d 74 74 20 61 72 65 61 70 (make-tt areap
2bb0: 61 74 68 3a 20 61 72 65 61 70 61 74 68 29 29 0a ath: areapath)).
2bc0: 09 20 28 64 62 66 6e 61 6d 65 20 28 6f 72 20 64 . (dbfname (or d
2bd0: 62 66 6e 61 6d 65 2d 69 6e 20 28 64 62 6d 6f 64 bfname-in (dbmod
2be0: 3a 72 75 6e 2d 69 64 2d 3e 64 62 66 6e 61 6d 65 :run-id->dbfname
2bf0: 20 72 75 6e 2d 69 64 29 29 29 29 0a 20 20 20 20 run-id)))).
2c00: 3b 3b 20 28 73 65 72 76 65 72 73 20 28 74 74 3a ;; (servers (tt:
2c10: 66 69 6e 64 2d 73 65 72 76 65 72 20 61 72 65 61 find-server area
2c20: 70 61 74 68 20 64 62 66 6e 61 6d 65 29 29 29 20 path dbfname)))
2c30: 3b 3b 20 73 68 6f 75 6c 64 20 75 73 65 20 74 74 ;; should use tt
2c40: 3a 67 65 74 2d 63 75 72 72 65 6e 74 2d 73 65 72 :get-current-ser
2c50: 76 65 72 2d 69 6e 66 6f 20 69 6e 73 74 65 61 64 ver-info instead
2c60: 0a 20 20 20 20 3b 3b 20 28 69 66 20 28 6e 75 6c . ;; (if (nul
2c70: 6c 3f 20 73 65 72 76 65 72 73 29 0a 20 20 20 20 l? servers).
2c80: 28 6c 65 74 2a 20 28 28 64 62 73 74 72 75 63 74 (let* ((dbstruct
2c90: 20 20 20 28 64 62 6d 6f 64 3a 6f 70 65 6e 2d 64 (dbmod:open-d
2ca0: 62 6d 6f 64 64 62 20 61 72 65 61 70 61 74 68 20 bmoddb areapath
2cb0: 72 75 6e 2d 69 64 20 64 62 66 6e 61 6d 65 20 28 run-id dbfname (
2cc0: 64 62 66 69 6c 65 3a 64 62 2d 69 6e 69 74 2d 70 dbfile:db-init-p
2cd0: 72 6f 63 29 20 6b 65 79 73 29 29 29 0a 20 20 20 roc) keys))).
2ce0: 20 20 20 28 74 74 2d 68 61 6e 64 6c 65 72 2d 73 (tt-handler-s
2cf0: 65 74 21 20 74 74 64 61 74 20 28 68 61 6e 64 6c et! ttdat (handl
2d00: 65 72 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 er dbstruct)).
2d10: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 63 70 2d (let* ((tcp-
2d20: 74 68 72 65 61 64 20 28 6d 61 6b 65 2d 74 68 72 thread (make-thr
2d30: 65 61 64 0a 09 09 09 20 20 28 6c 61 6d 62 64 61 ead.... (lambda
2d40: 20 28 29 0a 09 09 09 20 20 20 20 28 74 74 3a 73 ().... (tt:s
2d50: 74 61 72 74 2d 74 63 70 2d 73 65 72 76 65 72 20 tart-tcp-server
2d60: 74 74 64 61 74 29 29 20 3b 3b 20 73 74 61 72 74 ttdat)) ;; start
2d70: 20 74 68 65 20 74 63 70 2d 73 65 72 76 65 72 20 the tcp-server
2d80: 77 68 69 63 68 20 61 70 70 6c 69 65 73 20 68 61 which applies ha
2d90: 6e 64 6c 65 72 20 74 6f 20 69 6e 63 6f 6d 69 6e ndler to incomin
2da0: 67 20 64 61 74 61 0a 09 09 09 20 20 22 74 63 70 g data.... "tcp
2db0: 2d 73 65 72 76 65 72 2d 74 68 72 65 61 64 22 29 -server-thread")
2dc0: 29 0a 09 20 20 20 20 20 28 72 75 6e 2d 74 68 72 ).. (run-thr
2dd0: 65 61 64 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 ead (make-thread
2de0: 0a 09 09 09 20 20 28 6c 61 6d 62 64 61 20 28 29 .... (lambda ()
2df0: 0a 09 09 09 20 20 20 20 28 74 74 3a 6b 65 65 70 .... (tt:keep
2e00: 2d 72 75 6e 6e 69 6e 67 20 74 74 64 61 74 20 64 -running ttdat d
2e10: 62 66 6e 61 6d 65 20 64 62 73 74 72 75 63 74 29 bfname dbstruct)
2e20: 29 29 29 29 0a 09 28 74 68 72 65 61 64 2d 73 74 ))))..(thread-st
2e30: 61 72 74 21 20 74 63 70 2d 74 68 72 65 61 64 29 art! tcp-thread)
2e40: 0a 09 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 ..(thread-start!
2e50: 20 72 75 6e 2d 74 68 72 65 61 64 29 0a 09 28 74 run-thread)..(t
2e60: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 72 75 6e 2d hread-join! run-
2e70: 74 68 72 65 61 64 29 20 3b 3b 20 72 75 6e 20 74 thread) ;; run t
2e80: 68 72 65 61 64 20 77 69 6c 6c 20 65 78 69 74 20 hread will exit
2e90: 6f 6e 20 74 69 6d 65 6f 75 74 20 6f 72 20 6f 74 on timeout or ot
2ea0: 68 65 72 20 63 6f 6e 64 69 74 69 6f 6e 73 0a 09 her conditions..
2eb0: 28 65 78 69 74 29 29 29 0a 20 20 20 20 3b 3b 28 (exit))). ;;(
2ec0: 62 65 67 69 6e 0a 20 20 20 20 3b 3b 20 28 64 65 begin. ;; (de
2ed0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
2ee0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2ef0: 49 4e 46 4f 3a 20 66 6f 75 6e 64 20 73 65 72 76 INFO: found serv
2f00: 65 72 28 73 29 20 61 6c 72 65 61 64 79 20 72 75 er(s) already ru
2f10: 6e 6e 69 6e 67 20 66 6f 72 20 64 62 20 22 64 62 nning for db "db
2f20: 66 6e 61 6d 65 22 2c 20 22 28 73 74 72 69 6e 67 fname", "(string
2f30: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 73 65 72 -intersperse ser
2f40: 76 65 72 73 20 22 2c 22 29 22 20 45 78 69 74 69 vers ",")" Exiti
2f50: 6e 67 2e 22 29 0a 20 20 20 20 3b 3b 20 28 65 78 ng."). ;; (ex
2f60: 69 74 29 29 29 29 29 0a 20 20 20 20 29 29 0a 0a it))))). ))..
2f70: 28 64 65 66 69 6e 65 20 28 74 74 3a 6b 65 65 70 (define (tt:keep
2f80: 2d 72 75 6e 6e 69 6e 67 20 74 74 64 61 74 20 64 -running ttdat d
2f90: 62 66 6e 61 6d 65 20 64 62 73 74 72 75 63 74 29 bfname dbstruct)
2fa0: 0a 20 20 3b 3b 20 76 65 72 66 69 79 20 63 6f 6e . ;; verfiy con
2fb0: 6e 20 66 6f 72 20 72 65 61 64 79 0a 20 20 3b 3b n for ready. ;;
2fc0: 20 6c 69 73 74 65 6e 65 72 20 73 6f 63 6b 65 74 listener socket
2fd0: 20 68 61 73 20 62 65 65 6e 20 73 74 61 72 74 65 has been starte
2fe0: 64 20 62 79 20 74 68 69 73 20 73 74 61 67 65 0a d by this stage.
2ff0: 20 20 3b 3b 20 77 61 69 74 20 66 6f 72 20 61 20 ;; wait for a
3000: 70 6f 72 74 20 62 65 66 6f 72 65 20 63 72 65 61 port before crea
3010: 74 69 6e 67 20 74 68 65 20 72 65 67 69 73 74 72 ting the registr
3020: 61 74 69 6f 6e 20 66 69 6c 65 0a 20 20 3b 3b 0a ation file. ;;.
3030: 20 20 28 6c 65 74 2a 20 28 28 63 6c 65 61 6e 75 (let* ((cleanu
3040: 70 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 p (lambda ()...
3050: 20 20 20 28 69 66 20 28 74 74 2d 63 6c 65 61 6e (if (tt-clean
3060: 75 70 2d 70 72 6f 63 20 74 74 64 61 74 29 0a 09 up-proc ttdat)..
3070: 09 09 28 28 74 74 2d 63 6c 65 61 6e 75 70 2d 70 ..((tt-cleanup-p
3080: 72 6f 63 20 74 74 64 61 74 29 29 29 29 29 29 0a roc ttdat)))))).
3090: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
30a0: 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 20 count 0)).
30b0: 28 69 66 20 28 3e 20 63 6f 75 6e 74 20 32 34 30 (if (> count 240
30c0: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
30d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
30e0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
30f0: 74 2a 20 22 46 41 54 41 4c 3a 20 43 6f 75 6c 64 t* "FATAL: Could
3100: 20 6e 6f 74 20 73 74 61 72 74 20 61 20 74 63 70 not start a tcp
3110: 20 73 65 72 76 65 72 2c 20 67 69 76 69 6e 67 20 server, giving
3120: 75 70 2e 22 29 0a 09 20 20 20 20 28 65 78 69 74 up.").. (exit
3130: 20 31 29 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 1)).. (if (not
3140: 20 28 74 74 2d 70 6f 72 74 20 74 74 64 61 74 29 (tt-port ttdat)
3150: 29 20 3b 3b 20 6e 6f 20 63 6f 6e 6e 65 63 74 69 ) ;; no connecti
3160: 6f 6e 20 79 65 74 0a 09 20 20 20 20 20 20 28 62 on yet.. (b
3170: 65 67 69 6e 0a 09 09 28 74 68 72 65 61 64 2d 73 egin...(thread-s
3180: 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 09 28 6c leep! 0.25)...(l
3190: 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 oop (+ count 1))
31a0: 29 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b )))). . ;;
31b0: 20 6c 6f 61 64 20 6f 72 20 72 65 6c 6f 61 64 20 load or reload
31c0: 74 68 65 20 64 61 74 61 20 69 6e 74 6f 20 69 6e the data into in
31d0: 6d 65 6d 20 64 62 20 62 65 66 6f 72 65 0a 20 20 mem db before.
31e0: 20 20 3b 3b 20 28 28 64 62 72 3a 64 62 73 74 72 ;; ((dbr:dbstr
31f0: 75 63 74 2d 73 79 6e 63 2d 70 72 6f 63 20 64 62 uct-sync-proc db
3200: 73 74 72 75 63 74 29 20 28 64 62 72 3a 64 62 73 struct) (dbr:dbs
3210: 74 72 75 63 74 2d 6c 61 73 74 2d 75 70 64 61 74 truct-last-updat
3220: 65 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 20 e dbstruct)).
3230: 20 3b 3b 20 28 64 62 72 3a 64 62 73 74 72 75 63 ;; (dbr:dbstruc
3240: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 65 t-last-update-se
3250: 74 21 20 64 62 73 74 72 75 63 74 20 28 2d 20 28 t! dbstruct (- (
3260: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
3270: 20 31 29 29 0a 20 20 20 20 28 74 74 3a 63 72 65 1)). (tt:cre
3280: 61 74 65 2d 73 65 72 76 65 72 2d 72 65 67 69 73 ate-server-regis
3290: 74 72 61 74 69 6f 6e 2d 66 69 6c 65 20 74 74 64 tration-file ttd
32a0: 61 74 20 64 62 66 6e 61 6d 65 29 0a 20 20 20 20 at dbfname).
32b0: 3b 3b 20 6e 6f 77 20 73 74 61 72 74 20 77 61 74 ;; now start wat
32c0: 63 68 69 6e 67 20 74 68 65 20 6c 61 73 74 2d 61 ching the last-a
32d0: 63 63 65 73 73 2c 20 69 66 20 69 74 20 68 61 73 ccess, if it has
32e0: 6e 27 74 20 62 65 65 6e 20 74 6f 75 63 68 65 64 n't been touched
32f0: 0a 20 20 20 20 3b 3b 20 69 6e 20 6f 76 65 72 20 . ;; in over
3300: 74 65 6e 20 73 65 63 6f 6e 64 73 20 77 65 20 65 ten seconds we e
3310: 78 69 74 0a 20 20 20 20 28 74 68 72 65 61 64 2d xit. (thread-
3320: 73 6c 65 65 70 21 20 30 2e 30 35 29 20 3b 3b 20 sleep! 0.05) ;;
3330: 61 6e 79 20 72 65 61 6c 20 6e 65 65 64 20 66 6f any real need fo
3340: 72 20 64 65 6c 61 79 20 68 65 72 65 3f 0a 20 20 r delay here?.
3350: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 20 (let loop ().
3360: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 65 72 (let* ((ser
3370: 76 65 72 73 20 28 74 74 3a 67 65 74 2d 73 65 72 vers (tt:get-ser
3380: 76 65 72 2d 69 6e 66 6f 2d 73 6f 72 74 65 64 20 ver-info-sorted
3390: 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 29 0a ttdat dbfname)).
33a0: 09 20 20 20 20 20 28 6f 6b 20 20 20 20 20 20 28 . (ok (
33b0: 63 6f 6e 64 0a 09 09 20 20 20 20 20 20 20 28 28 cond... ((
33c0: 6e 75 6c 6c 3f 20 73 65 72 76 65 72 73 29 20 23 null? servers) #
33d0: 66 29 20 3b 3b 20 6e 6f 74 20 6f 6b 0a 09 09 20 f) ;; not ok...
33e0: 20 20 20 20 20 20 28 28 65 71 75 61 6c 3f 20 28 ((equal? (
33f0: 6c 69 73 74 2d 72 65 66 20 28 63 61 72 20 73 65 list-ref (car se
3400: 72 76 65 72 73 29 20 36 29 20 3b 3b 20 63 6f 6d rvers) 6) ;; com
3410: 70 61 72 65 20 74 68 65 20 73 65 72 76 69 6e 66 pare the servinf
3420: 6f 66 69 6c 65 0a 09 09 09 09 28 74 74 2d 73 65 ofile.....(tt-se
3430: 72 76 69 6e 66 2d 66 69 6c 65 20 74 74 64 61 74 rvinf-file ttdat
3440: 29 29 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 ))....(debug:pri
3450: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
3460: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4b 65 lt-log-port* "Ke
3470: 65 70 20 72 75 6e 6e 69 6e 67 2c 20 49 27 6d 20 ep running, I'm
3480: 74 68 65 20 74 6f 70 20 73 65 72 76 65 72 2e 22 the top server."
3490: 29 0a 09 09 09 23 74 29 0a 09 09 20 20 20 20 20 )....#t)...
34a0: 20 20 28 65 6c 73 65 0a 09 09 09 28 64 65 62 75 (else....(debu
34b0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
34c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
34d0: 2a 20 22 49 27 6d 20 6e 6f 74 20 74 68 65 20 6c * "I'm not the l
34e0: 65 61 64 20 73 65 72 76 65 72 3a 20 22 73 65 72 ead server: "ser
34f0: 76 65 72 73 29 0a 09 09 09 28 6c 65 74 2a 20 28 vers)....(let* (
3500: 28 6c 65 61 64 73 72 76 20 28 63 61 72 20 73 65 (leadsrv (car se
3510: 72 76 65 72 73 29 29 29 0a 09 09 09 20 20 28 6d rvers))).... (m
3520: 61 74 63 68 20 6c 65 61 64 73 72 76 0a 09 09 09 atch leadsrv....
3530: 20 20 20 20 28 28 68 6f 73 74 20 70 6f 72 74 20 ((host port
3540: 73 74 61 72 74 73 65 63 6f 6e 64 73 20 73 65 72 startseconds ser
3550: 76 65 72 2d 69 64 20 70 69 64 20 64 62 66 6e 61 ver-id pid dbfna
3560: 6d 65 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 me servinfofile)
3570: 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 74 74 .... (if (tt
3580: 3a 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 :ping host port
3590: 73 65 72 76 65 72 2d 69 64 29 0a 09 09 09 09 20 server-id).....
35a0: 23 66 20 3b 3b 20 6e 6f 74 20 74 68 65 20 73 65 #f ;; not the se
35b0: 72 76 65 72 2c 20 62 75 74 20 61 6c 6c 20 67 6f rver, but all go
35c0: 6f 64 2c 20 77 61 6e 74 20 74 6f 20 65 78 69 74 od, want to exit
35d0: 0a 09 09 09 09 20 28 69 66 20 28 61 6e 64 20 28 ..... (if (and (
35e0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 65 72 file-exists? ser
35f0: 76 69 6e 66 6f 66 69 6c 65 29 0a 09 09 09 09 09 vinfofile)......
3600: 20 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 (> (- (current
3610: 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d -seconds)(file-m
3620: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
3630: 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 29 29 20 servinfofile))
3640: 35 29 29 0a 09 09 09 09 20 20 20 20 20 28 62 65 5))..... (be
3650: 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 20 3b gin..... ;
3660: 3b 20 63 61 6e 27 74 20 70 69 6e 67 20 61 6e 64 ; can't ping and
3670: 20 66 69 6c 65 20 68 61 73 20 62 65 65 6e 20 6f file has been o
3680: 6e 20 64 69 73 6b 20 35 20 73 65 63 6f 6e 64 73 n disk 5 seconds
3690: 2c 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 74 , go ahead and t
36a0: 72 79 20 74 6f 20 72 65 6d 6f 76 65 20 69 74 0a ry to remove it.
36b0: 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
36c0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
36d0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
36e0: 2a 20 22 52 65 6d 6f 76 69 6e 67 20 61 70 70 61 * "Removing appa
36f0: 72 65 6e 74 6c 79 20 64 65 61 64 20 73 65 72 76 rently dead serv
3700: 65 72 20 69 6e 66 6f 20 66 69 6c 65 3a 20 22 73 er info file: "s
3710: 65 72 76 69 6e 66 6f 66 69 6c 65 29 0a 09 09 09 ervinfofile)....
3720: 09 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d . (delete-
3730: 66 69 6c 65 2a 20 73 65 72 76 69 6e 66 6f 66 69 file* servinfofi
3740: 6c 65 29 0a 09 09 09 09 20 20 20 20 20 20 20 23 le)..... #
3750: 74 29 20 3b 3b 20 6e 6f 74 20 74 68 65 20 73 65 t) ;; not the se
3760: 72 76 65 72 20 62 75 74 20 74 68 65 20 73 65 72 rver but the ser
3770: 76 65 72 20 69 73 20 6e 6f 74 20 72 65 61 63 68 ver is not reach
3780: 61 62 6c 65 0a 09 09 09 09 20 20 20 20 20 23 74 able..... #t
3790: 29 29 29 0a 09 09 09 20 20 20 20 28 65 6c 73 65 ))).... (else
37a0: 20 3b 3b 20 73 68 6f 75 6c 64 20 6e 65 76 65 72 ;; should never
37b0: 20 67 65 74 20 68 65 72 65 0a 09 09 09 20 20 20 get here....
37c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
37d0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
37e0: 72 74 2a 20 22 42 41 44 20 53 45 52 56 45 52 20 rt* "BAD SERVER
37f0: 52 45 43 4f 52 44 3a 20 22 6c 65 61 64 73 72 76 RECORD: "leadsrv
3800: 29 0a 09 09 09 20 20 20 20 20 28 61 73 73 65 72 ).... (asser
3810: 74 20 23 66 20 22 42 61 64 20 73 65 72 76 65 72 t #f "Bad server
3820: 20 72 65 63 6f 72 64 20 22 6c 65 61 64 73 72 76 record "leadsrv
3830: 29 29 29 29 29 29 29 29 0a 09 28 69 66 20 6f 6b ))))))))..(if ok
3840: 0a 09 20 20 20 20 3b 3b 20 28 69 66 20 28 3e 20 .. ;; (if (>
3850: 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 *api-process-req
3860: 75 65 73 74 2d 63 6f 75 6e 74 2a 20 30 29 20 3b uest-count* 0) ;
3870: 3b 20 68 61 76 65 20 72 65 71 75 65 73 74 73 20 ; have requests
3880: 69 6e 20 66 6c 69 67 68 74 0a 09 20 20 20 20 3b in flight.. ;
3890: 3b 09 28 74 74 2d 6c 61 73 74 2d 61 63 63 65 73 ;.(tt-last-acces
38a0: 73 2d 73 65 74 21 20 74 74 64 61 74 20 28 63 75 s-set! ttdat (cu
38b0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
38c0: 0a 09 20 20 20 20 28 74 74 2d 6c 61 73 74 2d 61 .. (tt-last-a
38d0: 63 63 65 73 73 2d 73 65 74 21 20 74 74 64 61 74 ccess-set! ttdat
38e0: 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 *db-last-access
38f0: 2a 29 20 3b 3b 20 62 69 74 20 73 69 6c 6c 79 2c *) ;; bit silly,
3900: 20 6a 75 73 74 20 75 73 65 20 64 62 2d 6c 61 73 just use db-las
3910: 74 2d 61 63 63 65 73 73 0a 09 20 20 20 20 28 62 t-access.. (b
3920: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 63 6c 65 egin.. (cle
3930: 61 6e 75 70 29 0a 09 20 20 20 20 20 20 28 65 78 anup).. (ex
3940: 69 74 29 29 29 0a 0a 09 28 6c 65 74 2a 20 28 28 it)))...(let* ((
3950: 6c 61 73 74 2d 75 70 64 61 74 65 20 28 64 62 72 last-update (dbr
3960: 3a 64 62 73 74 72 75 63 74 2d 6c 61 73 74 2d 75 :dbstruct-last-u
3970: 70 64 61 74 65 20 64 62 73 74 72 75 63 74 29 29 pdate dbstruct))
3980: 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 2d 73 .. (curr-s
3990: 65 63 73 20 20 20 28 63 75 72 72 65 6e 74 2d 73 ecs (current-s
39a0: 65 63 6f 6e 64 73 29 29 29 0a 09 20 20 28 69 66 econds))).. (if
39b0: 20 28 3e 20 28 2d 20 63 75 72 72 2d 73 65 63 73 (> (- curr-secs
39c0: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 20 33 29 last-update) 3)
39d0: 20 3b 3b 20 65 76 65 72 79 20 33 2d 34 20 73 65 ;; every 3-4 se
39e0: 63 6f 6e 64 73 20 75 70 64 61 74 65 20 74 68 65 conds update the
39f0: 20 64 62 3f 20 6d 61 79 62 65 20 74 68 69 73 20 db? maybe this
3a00: 73 68 6f 75 6c 64 20 62 65 20 72 65 66 72 65 73 should be refres
3a10: 68 20 74 68 65 20 69 6e 6d 65 6d 3f 0a 09 20 20 h the inmem?..
3a20: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 28 64 (begin...((d
3a30: 62 72 3a 64 62 73 74 72 75 63 74 2d 73 79 6e 63 br:dbstruct-sync
3a40: 2d 70 72 6f 63 20 64 62 73 74 72 75 63 74 29 20 -proc dbstruct)
3a50: 6c 61 73 74 2d 75 70 64 61 74 65 29 0a 09 09 28 last-update)...(
3a60: 64 62 72 3a 64 62 73 74 72 75 63 74 2d 6c 61 73 dbr:dbstruct-las
3a70: 74 2d 75 70 64 61 74 65 2d 73 65 74 21 20 64 62 t-update-set! db
3a80: 73 74 72 75 63 74 20 63 75 72 72 2d 73 65 63 73 struct curr-secs
3a90: 29 29 29 29 0a 09 20 20 0a 09 28 69 66 20 28 3c )))).. ..(if (<
3aa0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
3ab0: 6f 6e 64 73 29 20 28 74 74 2d 6c 61 73 74 2d 61 onds) (tt-last-a
3ac0: 63 63 65 73 73 20 74 74 64 61 74 29 29 20 36 30 ccess ttdat)) 60
3ad0: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
3ae0: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
3af0: 65 70 21 20 35 29 0a 09 20 20 20 20 20 20 28 6c ep! 5).. (l
3b00: 6f 6f 70 29 29 29 29 29 0a 20 20 20 20 28 63 6c oop))))). (cl
3b10: 65 61 6e 75 70 29 0a 20 20 20 20 28 64 65 62 75 eanup). (debu
3b20: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3b30: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
3b40: 46 4f 3a 20 53 65 72 76 65 72 20 74 69 6d 65 64 FO: Server timed
3b50: 20 6f 75 74 2c 20 65 78 69 74 69 6e 67 2e 22 29 out, exiting.")
3b60: 29 29 0a 0a 20 20 0a 3b 3b 20 3b 3b 20 67 69 76 )).. .;; ;; giv
3b70: 65 6e 20 61 6e 20 61 6c 72 65 61 64 79 20 73 65 en an already se
3b80: 74 20 75 70 20 75 63 6f 6e 6e 20 73 74 61 72 74 t up uconn start
3b90: 20 74 68 65 20 63 6d 64 2d 6c 6f 6f 70 0a 3b 3b the cmd-loop.;;
3ba0: 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;.;; (define (
3bb0: 74 74 3a 63 6d 64 2d 6c 6f 6f 70 20 74 74 64 61 tt:cmd-loop ttda
3bc0: 74 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 t).;; (let* ((
3bd0: 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 28 2d serv-listener (-
3be0: 73 6f 63 6b 65 74 20 75 63 6f 6e 6e 29 29 0a 3b socket uconn)).;
3bf0: 3b 20 09 20 28 6c 69 73 74 65 6e 65 72 20 20 20 ; . (listener
3c00: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b (lambda ().;;
3c10: 20 09 09 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ... (let loop
3c20: 28 28 73 74 61 74 65 20 27 73 74 61 72 74 29 29 ((state 'start))
3c30: 0a 3b 3b 20 09 09 09 20 20 20 20 28 6c 65 74 2d .;; ... (let-
3c40: 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 6f 75 values (((inp ou
3c50: 70 29 28 74 63 70 2d 61 63 63 65 70 74 20 73 65 p)(tcp-accept se
3c60: 72 76 2d 6c 69 73 74 65 6e 65 72 29 29 29 0a 3b rv-listener))).;
3c70: 3b 20 09 09 09 20 20 20 20 20 20 3b 3b 20 28 6d ; ... ;; (m
3c80: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 73 65 6e 64 utex-lock! *send
3c90: 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 44 4f 45 53 -mutex*) ;; DOES
3ca0: 4e 27 54 20 53 45 45 4d 20 54 4f 20 48 45 4c 50 N'T SEEM TO HELP
3cb0: 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 28 6c 65 .;; ... (le
3cc0: 74 2a 20 28 28 72 64 61 74 20 20 28 64 65 73 65 t* ((rdat (dese
3cd0: 72 69 61 6c 69 7a 65 20 69 6e 70 29 29 20 3b 3b rialize inp)) ;;
3ce0: 20 27 28 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 20 '(my-host-port
3cf0: 71 72 79 6b 65 79 20 63 6d 64 20 70 61 72 61 6d qrykey cmd param
3d00: 73 29 0a 3b 3b 20 09 09 09 09 20 20 20 20 20 28 s).;; .... (
3d10: 72 65 73 70 20 20 28 75 6c 65 78 2d 68 61 6e 64 resp (ulex-hand
3d20: 6c 65 72 20 75 63 6f 6e 6e 20 72 64 61 74 29 29 ler uconn rdat))
3d30: 29 0a 3b 3b 20 09 09 09 09 28 73 65 72 69 61 6c ).;; ....(serial
3d40: 69 7a 65 20 72 65 73 70 20 6f 75 70 29 0a 3b 3b ize resp oup).;;
3d50: 20 09 09 09 09 28 63 6c 6f 73 65 2d 69 6e 70 75 ....(close-inpu
3d60: 74 2d 70 6f 72 74 20 69 6e 70 29 0a 3b 3b 20 09 t-port inp).;; .
3d70: 09 09 09 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 ...(close-output
3d80: 2d 70 6f 72 74 20 6f 75 70 29 0a 3b 3b 20 09 09 -port oup).;; ..
3d90: 09 09 3b 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f ..;; (mutex-unlo
3da0: 63 6b 21 20 2a 73 65 6e 64 2d 6d 75 74 65 78 2a ck! *send-mutex*
3db0: 29 20 3b 3b 20 44 4f 45 53 4e 27 54 20 53 45 45 ) ;; DOESN'T SEE
3dc0: 4d 20 54 4f 20 48 45 4c 50 0a 3b 3b 20 09 09 09 M TO HELP.;; ...
3dd0: 09 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 28 .).;; ... (
3de0: 6c 6f 6f 70 20 73 74 61 74 65 29 29 29 29 29 29 loop state))))))
3df0: 0a 3b 3b 20 20 20 20 20 3b 3b 20 73 74 61 72 74 .;; ;; start
3e00: 20 4e 20 6f 66 20 74 68 65 6d 0a 3b 3b 20 20 20 N of them.;;
3e10: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 68 (let loop ((th
3e20: 6e 75 6d 20 20 20 30 29 0a 3b 3b 20 09 20 20 20 num 0).;; .
3e30: 20 20 20 20 28 74 68 72 65 61 64 73 20 27 28 29 (threads '()
3e40: 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 69 66 20 )).;; (if
3e50: 28 3c 20 74 68 6e 75 6d 20 31 30 30 29 0a 3b 3b (< thnum 100).;;
3e60: 20 09 20 20 28 6c 65 74 2a 20 28 28 74 68 20 28 . (let* ((th (
3e70: 6d 61 6b 65 2d 74 68 72 65 61 64 20 6c 69 73 74 make-thread list
3e80: 65 6e 65 72 20 28 63 6f 6e 63 20 22 6c 69 73 74 ener (conc "list
3e90: 65 6e 65 72 22 20 74 68 6e 75 6d 29 29 29 29 0a ener" thnum)))).
3ea0: 3b 3b 20 09 20 20 20 20 28 74 68 72 65 61 64 2d ;; . (thread-
3eb0: 73 74 61 72 74 21 20 74 68 29 0a 3b 3b 20 09 20 start! th).;; .
3ec0: 20 20 20 28 6c 6f 6f 70 20 28 2b 20 74 68 6e 75 (loop (+ thnu
3ed0: 6d 20 31 29 0a 3b 3b 20 09 09 20 20 28 63 6f 6e m 1).;; .. (con
3ee0: 73 20 74 68 20 74 68 72 65 61 64 73 29 29 29 0a s th threads))).
3ef0: 3b 3b 20 09 20 20 28 6d 61 70 20 74 68 72 65 61 ;; . (map threa
3f00: 64 2d 6a 6f 69 6e 21 20 74 68 72 65 61 64 73 29 d-join! threads)
3f10: 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 0a 3b 3b 20 )))).;; .;; .;;
3f20: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 77 61 69 .;; (define (wai
3f30: 74 2d 61 6e 64 2d 63 6c 6f 73 65 20 75 63 6f 6e t-and-close ucon
3f40: 6e 29 0a 3b 3b 20 20 20 28 74 68 72 65 61 64 2d n).;; (thread-
3f50: 6a 6f 69 6e 21 20 28 75 64 61 74 2d 63 6d 64 2d join! (udat-cmd-
3f60: 74 68 72 65 61 64 20 75 63 6f 6e 6e 29 29 0a 3b thread uconn)).;
3f70: 3b 20 20 20 28 74 63 70 2d 63 6c 6f 73 65 20 28 ; (tcp-close (
3f80: 75 64 61 74 2d 73 6f 63 6b 65 74 20 75 63 6f 6e udat-socket ucon
3f90: 6e 29 29 29 0a 3b 3b 20 0a 3b 3b 20 0a 0a 28 64 n))).;; .;; ..(d
3fa0: 65 66 69 6e 65 20 28 74 74 3a 73 68 75 74 64 6f efine (tt:shutdo
3fb0: 77 6e 2d 73 65 72 76 65 72 20 74 74 64 61 74 29 wn-server ttdat)
3fc0: 0a 20 20 28 6c 65 74 2a 20 28 28 63 6c 65 61 6e . (let* ((clean
3fd0: 70 72 6f 63 20 28 74 74 2d 63 6c 65 61 6e 75 70 proc (tt-cleanup
3fe0: 2d 70 72 6f 63 20 74 74 64 61 74 29 29 29 0a 20 -proc ttdat))).
3ff0: 20 20 20 28 69 66 20 63 6c 65 61 6e 70 72 6f 63 (if cleanproc
4000: 20 28 63 6c 65 61 6e 70 72 6f 63 29 29 0a 20 20 (cleanproc)).
4010: 20 20 28 74 63 70 2d 63 6c 6f 73 65 20 28 74 74 (tcp-close (tt
4020: 2d 73 6f 63 6b 65 74 20 74 74 64 61 74 29 29 20 -socket ttdat))
4030: 3b 3b 20 63 6c 6f 73 65 20 75 70 20 70 6f 72 74 ;; close up port
4040: 73 20 68 65 72 65 0a 20 20 20 20 29 29 0a 0a 3b s here. ))..;
4050: 3b 20 28 64 65 66 69 6e 65 20 28 77 61 69 74 2d ; (define (wait-
4060: 61 6e 64 2d 63 6c 6f 73 65 20 75 63 6f 6e 6e 29 and-close uconn)
4070: 0a 3b 3b 20 20 20 28 74 68 72 65 61 64 2d 6a 6f .;; (thread-jo
4080: 69 6e 21 20 28 74 74 2d 63 6d 64 2d 74 68 72 65 in! (tt-cmd-thre
4090: 61 64 20 75 63 6f 6e 6e 29 29 0a 3b 3b 20 20 20 ad uconn)).;;
40a0: 28 74 63 70 2d 63 6c 6f 73 65 20 28 74 74 2d 73 (tcp-close (tt-s
40b0: 6f 63 6b 65 74 20 75 63 6f 6e 6e 29 29 29 0a 0a ocket uconn)))..
40c0: 3b 3b 20 72 65 74 75 72 6e 20 73 65 72 76 69 64 ;; return servid
40d0: 0a 3b 3b 20 73 69 64 65 2d 65 66 66 65 63 74 73 .;; side-effects
40e0: 3a 0a 3b 3b 20 20 20 74 74 64 61 74 2d 63 6c 65 :.;; ttdat-cle
40f0: 61 6e 75 70 2d 70 72 6f 63 20 69 73 20 70 6f 70 anup-proc is pop
4100: 75 6c 61 74 65 64 20 77 69 74 68 20 66 75 6e 63 ulated with func
4110: 74 69 6f 6e 20 74 6f 20 72 65 6d 6f 76 65 20 74 tion to remove t
4120: 68 65 20 73 65 72 76 65 72 69 6e 66 6f 20 66 69 he serverinfo fi
4130: 6c 65 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 63 le.(define (tt:c
4140: 72 65 61 74 65 2d 73 65 72 76 65 72 2d 72 65 67 reate-server-reg
4150: 69 73 74 72 61 74 69 6f 6e 2d 66 69 6c 65 20 74 istration-file t
4160: 74 64 61 74 20 64 62 66 6e 61 6d 65 29 0a 20 20 tdat dbfname).
4170: 28 6c 65 74 2a 20 28 28 61 72 65 61 70 61 74 68 (let* ((areapath
4180: 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 74 74 (tt-areapath tt
4190: 64 61 74 29 29 0a 09 20 28 73 65 72 76 64 69 72 dat)).. (servdir
41a0: 20 20 28 74 74 3a 67 65 74 2d 73 65 72 76 69 6e (tt:get-servin
41b0: 66 6f 2d 64 69 72 20 61 72 65 61 70 61 74 68 29 fo-dir areapath)
41c0: 29 0a 09 20 28 68 6f 73 74 20 20 20 20 20 28 74 ).. (host (t
41d0: 74 2d 68 6f 73 74 20 74 74 64 61 74 29 29 0a 09 t-host ttdat))..
41e0: 20 28 70 6f 72 74 20 20 20 20 20 28 74 74 2d 70 (port (tt-p
41f0: 6f 72 74 20 74 74 64 61 74 29 29 0a 09 20 28 73 ort ttdat)).. (s
4200: 65 72 76 69 6e 66 20 28 63 6f 6e 63 20 73 65 72 ervinf (conc ser
4210: 76 64 69 72 22 2f 22 68 6f 73 74 22 3a 22 70 6f vdir"/"host":"po
4220: 72 74 22 2d 22 28 63 75 72 72 65 6e 74 2d 70 72 rt"-"(current-pr
4230: 6f 63 65 73 73 2d 69 64 29 22 3a 22 64 62 66 6e ocess-id)":"dbfn
4240: 61 6d 65 29 29 0a 09 20 28 73 65 72 76 2d 69 64 ame)).. (serv-id
4250: 20 28 74 74 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 (tt:mk-signatur
4260: 65 20 61 72 65 61 70 61 74 68 29 29 0a 09 20 28 e areapath)).. (
4270: 63 6c 65 61 6e 2d 70 72 6f 63 20 28 6c 61 6d 62 clean-proc (lamb
4280: 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 da ()... (
4290: 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 73 65 72 delete-file* ser
42a0: 76 69 6e 66 29 29 29 29 0a 20 20 20 20 28 61 73 vinf)))). (as
42b0: 73 65 72 74 20 28 61 6e 64 20 68 6f 73 74 20 70 sert (and host p
42c0: 6f 72 74 29 20 22 46 41 54 41 4c 3a 20 74 74 3a ort) "FATAL: tt:
42d0: 63 72 65 61 74 65 2d 73 65 72 76 65 72 2d 72 65 create-server-re
42e0: 67 69 73 74 72 61 74 69 6f 6e 2d 66 69 6c 65 20 gistration-file
42f0: 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f 20 63 called with no c
4300: 6f 6e 6e 2c 20 64 62 66 6e 61 6d 65 3d 22 64 62 onn, dbfname="db
4310: 66 6e 61 6d 65 29 0a 20 20 20 20 28 74 74 2d 63 fname). (tt-c
4320: 6c 65 61 6e 75 70 2d 70 72 6f 63 2d 73 65 74 21 leanup-proc-set!
4330: 20 74 74 64 61 74 20 63 6c 65 61 6e 2d 70 72 6f ttdat clean-pro
4340: 63 29 0a 20 20 20 20 28 74 74 2d 73 65 72 76 69 c). (tt-servi
4350: 6e 66 2d 66 69 6c 65 2d 73 65 74 21 20 74 74 64 nf-file-set! ttd
4360: 61 74 20 73 65 72 76 69 6e 66 29 0a 20 20 20 20 at servinf).
4370: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
4380: 66 69 6c 65 20 73 65 72 76 69 6e 66 0a 20 20 20 file servinf.
4390: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 (lambda ()..(
43a0: 70 72 69 6e 74 20 22 53 45 52 56 45 52 20 53 54 print "SERVER ST
43b0: 41 52 54 45 44 3a 20 22 68 6f 73 74 22 3a 22 70 ARTED: "host":"p
43c0: 6f 72 74 22 20 41 54 20 22 28 63 75 72 72 65 6e ort" AT "(curren
43d0: 74 2d 73 65 63 6f 6e 64 73 29 22 20 73 65 72 76 t-seconds)" serv
43e0: 65 72 2d 69 64 3a 20 22 73 65 72 76 2d 69 64 22 er-id: "serv-id"
43f0: 20 70 69 64 3a 20 22 28 63 75 72 72 65 6e 74 2d pid: "(current-
4400: 70 72 6f 63 65 73 73 2d 69 64 29 22 20 64 62 66 process-id)" dbf
4410: 6e 61 6d 65 3a 20 22 64 62 66 6e 61 6d 65 29 29 name: "dbfname))
4420: 29 0a 20 20 20 20 20 20 73 65 72 76 2d 69 64 29 ). serv-id)
4430: 29 0a 0a 3b 3b 20 66 69 6e 64 20 76 61 6c 69 64 )..;; find valid
4440: 20 73 65 72 76 65 72 0a 3b 3b 20 67 65 74 20 73 server.;; get s
4450: 65 72 76 65 72 73 20 6c 69 73 74 65 64 2c 20 6c ervers listed, l
4460: 61 73 74 20 70 61 72 74 20 6f 66 20 6e 61 6d 65 ast part of name
4470: 20 6d 75 73 74 20 6d 61 74 63 68 20 3a 3c 64 62 must match :<db
4480: 66 6e 61 6d 65 3e 0a 3b 3b 20 69 66 20 6d 6f 72 fname>.;; if mor
4490: 65 20 74 68 61 6e 20 6f 6e 65 2c 20 77 61 69 74 e than one, wait
44a0: 20 6f 6e 65 20 73 65 63 6f 6e 64 20 61 6e 64 20 one second and
44b0: 6c 6f 6f 6b 20 61 67 61 69 6e 0a 3b 3b 20 66 75 look again.;; fu
44c0: 74 75 72 65 3a 20 70 69 6e 67 20 6f 6c 64 65 73 ture: ping oldes
44d0: 74 2c 20 69 66 20 61 6c 69 76 65 20 72 65 6d 6f t, if alive remo
44e0: 76 65 20 6f 74 68 65 72 20 3a 3c 64 62 66 6e 61 ve other :<dbfna
44f0: 6d 65 3e 20 66 69 6c 65 73 0a 3b 3b 0a 28 64 65 me> files.;;.(de
4500: 66 69 6e 65 20 28 74 74 3a 66 69 6e 64 2d 73 65 fine (tt:find-se
4510: 72 76 65 72 20 61 72 65 61 70 61 74 68 20 64 62 rver areapath db
4520: 66 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 fname). (let* (
4530: 28 73 65 72 76 64 69 72 20 20 28 74 74 3a 67 65 (servdir (tt:ge
4540: 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 t-servinfo-dir a
4550: 72 65 61 70 61 74 68 29 29 0a 09 20 28 73 66 69 reapath)).. (sfi
4560: 6c 65 73 20 20 20 28 67 6c 6f 62 20 28 63 6f 6e les (glob (con
4570: 63 20 73 65 72 76 64 69 72 22 2f 2a 3a 22 64 62 c servdir"/*:"db
4580: 66 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 73 66 fname)))). sf
4590: 69 6c 65 73 29 29 0a 0a 3b 3b 20 67 69 76 65 6e iles))..;; given
45a0: 20 61 20 70 61 74 68 20 74 6f 20 61 20 73 65 72 a path to a ser
45b0: 76 65 72 20 69 6e 66 6f 20 66 69 6c 65 20 72 65 ver info file re
45c0: 74 75 72 6e 3a 20 68 6f 73 74 20 70 6f 72 74 20 turn: host port
45d0: 73 74 61 72 74 73 65 63 6f 6e 64 73 20 73 65 72 startseconds ser
45e0: 76 65 72 2d 69 64 20 70 69 64 20 64 62 66 6e 61 ver-id pid dbfna
45f0: 6d 65 20 6c 6f 67 66 0a 3b 3b 20 65 78 61 6d 70 me logf.;; examp
4600: 6c 65 20 6f 66 20 77 68 61 74 20 69 74 27 73 20 le of what it's
4610: 6c 6f 6f 6b 69 6e 67 20 66 6f 72 20 69 6e 20 74 looking for in t
4620: 68 65 20 6c 6f 67 20 66 69 6c 65 3a 0a 3b 3b 20 he log file:.;;
4630: 20 20 20 20 53 45 52 56 45 52 20 53 54 41 52 54 SERVER START
4640: 45 44 3a 20 31 30 2e 33 38 2e 31 37 35 2e 36 37 ED: 10.38.175.67
4650: 3a 35 30 32 31 36 20 41 54 20 31 36 31 36 35 30 :50216 AT 161650
4660: 32 33 35 30 2e 30 20 73 65 72 76 65 72 2d 69 64 2350.0 server-id
4670: 3a 20 34 39 30 37 65 39 30 66 63 35 35 63 37 61 : 4907e90fc55c7a
4680: 30 39 36 39 34 65 33 66 36 35 38 63 36 33 39 63 09694e3f658c639c
4690: 66 34 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 f4 .;;.(define (
46a0: 74 74 3a 73 65 72 76 65 72 2d 67 65 74 2d 69 6e tt:server-get-in
46b0: 66 6f 20 6c 6f 67 66 29 0a 20 20 28 6c 65 74 20 fo logf). (let
46c0: 28 28 73 65 72 76 65 72 2d 72 78 20 20 20 20 28 ((server-rx (
46d0: 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 52 20 regexp "^SERVER
46e0: 53 54 41 52 54 45 44 3a 20 28 5c 5c 53 2b 29 3a STARTED: (\\S+):
46f0: 28 5c 5c 64 2b 29 20 41 54 20 28 5b 5c 5c 64 5c (\\d+) AT ([\\d\
4700: 5c 2e 5d 2b 29 20 73 65 72 76 65 72 2d 69 64 3a \.]+) server-id:
4710: 20 28 5c 5c 53 2b 29 20 70 69 64 3a 20 28 5c 5c (\\S+) pid: (\\
4720: 64 2b 29 20 64 62 66 6e 61 6d 65 3a 20 28 5c 5c d+) dbfname: (\\
4730: 53 2b 29 22 29 29 20 3b 3b 20 53 45 52 56 45 52 S+)")) ;; SERVER
4740: 20 53 54 41 52 54 45 44 3a 20 68 6f 73 74 3a 70 STARTED: host:p
4750: 6f 72 74 20 41 54 20 74 69 6d 65 73 65 63 73 20 ort AT timesecs
4760: 73 65 72 76 65 72 20 69 64 0a 20 20 20 20 20 20 server id.
4770: 20 20 28 64 62 70 72 65 70 2d 72 78 20 20 20 20 (dbprep-rx
4780: 28 72 65 67 65 78 70 20 22 5e 53 45 52 56 45 52 (regexp "^SERVER
4790: 3a 20 64 62 70 72 65 70 22 29 29 0a 20 20 20 20 : dbprep")).
47a0: 20 20 20 20 28 64 62 70 72 65 70 2d 66 6f 75 6e (dbprep-foun
47b0: 64 20 30 29 0a 09 28 62 61 64 2d 64 61 74 20 20 d 0)..(bad-dat
47c0: 20 20 20 20 28 6c 69 73 74 20 23 66 20 23 66 20 (list #f #f
47d0: 23 66 20 23 66 20 23 66 20 23 66 20 6c 6f 67 66 #f #f #f #f logf
47e0: 29 29 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 ))). (let ((
47f0: 66 64 61 74 20 20 20 20 20 28 68 61 6e 64 6c 65 fdat (handle
4800: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 -exceptions....
4810: 65 78 6e 0a 09 09 20 20 20 20 20 20 20 28 62 65 exn... (be
4820: 67 69 6e 0a 09 09 09 20 3b 3b 20 57 41 52 4e 49 gin.... ;; WARNI
4830: 4e 47 3a 20 74 68 69 73 20 69 73 20 70 6f 74 65 NG: this is pote
4840: 6e 74 69 61 6c 6c 79 20 64 61 6e 67 65 72 6f 75 ntially dangerou
4850: 73 20 74 6f 20 62 6c 61 6e 6b 65 74 20 69 67 6e s to blanket ign
4860: 6f 72 65 20 74 68 65 20 65 72 72 6f 72 73 0a 09 ore the errors..
4870: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
4880: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
4890: 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 61 62 6c log-port* "Unabl
48a0: 65 20 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 e to get server
48b0: 69 6e 66 6f 20 66 72 6f 6d 20 22 6c 6f 67 66 22 info from "logf"
48c0: 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 , exn=" exn)....
48d0: 20 27 28 29 29 20 3b 3b 20 6e 6f 20 69 64 65 61 '()) ;; no idea
48e0: 20 77 68 61 74 20 77 65 6e 74 20 77 72 6f 6e 67 what went wrong
48f0: 2c 20 63 61 6c 6c 20 69 74 20 61 20 62 61 64 20 , call it a bad
4900: 73 65 72 76 65 72 2c 20 72 65 74 75 72 6e 20 65 server, return e
4910: 6d 70 74 79 20 6c 69 73 74 0a 09 09 20 20 20 20 mpty list...
4920: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
4930: 72 6f 6d 2d 66 69 6c 65 20 6c 6f 67 66 20 72 65 rom-file logf re
4940: 61 64 2d 6c 69 6e 65 73 29 29 29 29 0a 20 20 20 ad-lines)))).
4950: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 (if (null? f
4960: 64 61 74 29 20 3b 3b 20 62 61 64 20 64 61 74 61 dat) ;; bad data
4970: 2c 20 72 65 74 75 72 6e 20 62 61 64 2d 64 61 74 , return bad-dat
4980: 0a 09 20 20 20 62 61 64 2d 64 61 74 0a 09 20 20 .. bad-dat..
4990: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c (let loop ((inl
49a0: 20 20 28 63 61 72 20 66 64 61 74 29 29 0a 09 09 (car fdat))...
49b0: 20 20 20 20 20 20 28 74 61 69 6c 20 28 63 64 72 (tail (cdr
49c0: 20 66 64 61 74 29 29 0a 09 09 20 20 20 20 20 20 fdat))...
49d0: 28 6c 6e 75 6d 20 30 29 29 0a 09 20 20 20 20 20 (lnum 0))..
49e0: 28 6c 65 74 20 28 28 6d 6c 73 74 20 28 73 74 72 (let ((mlst (str
49f0: 69 6e 67 2d 6d 61 74 63 68 20 73 65 72 76 65 72 ing-match server
4a00: 2d 72 78 20 69 6e 6c 29 29 0a 09 09 20 20 20 28 -rx inl))... (
4a10: 64 62 70 72 65 70 20 28 73 74 72 69 6e 67 2d 6d dbprep (string-m
4a20: 61 74 63 68 20 64 62 70 72 65 70 2d 72 78 20 69 atch dbprep-rx i
4a30: 6e 6c 29 29 29 0a 09 20 20 20 20 20 20 20 28 69 nl))).. (i
4a40: 66 20 64 62 70 72 65 70 20 28 73 65 74 21 20 64 f dbprep (set! d
4a50: 62 70 72 65 70 2d 66 6f 75 6e 64 20 31 29 29 0a bprep-found 1)).
4a60: 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 . (if (not
4a70: 20 6d 6c 73 74 29 0a 09 09 20 20 20 28 69 66 20 mlst)... (if
4a80: 28 3e 20 6c 6e 75 6d 20 35 30 30 29 20 3b 3b 20 (> lnum 500) ;;
4a90: 67 69 76 65 20 75 70 20 69 66 20 6d 6f 72 65 20 give up if more
4aa0: 74 68 61 6e 20 35 30 30 20 6c 69 6e 65 73 20 6f than 500 lines o
4ab0: 66 20 73 65 72 76 65 72 20 6c 6f 67 20 72 65 61 f server log rea
4ac0: 64 0a 09 09 20 20 20 20 20 20 20 62 61 64 2d 64 d... bad-d
4ad0: 61 74 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 at... (if
4ae0: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 09 09 (null? tail)....
4af0: 20 20 20 62 61 64 2d 64 61 74 0a 09 09 09 20 20 bad-dat....
4b00: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
4b10: 29 28 63 64 72 20 74 61 69 6c 29 28 2b 20 6c 6e )(cdr tail)(+ ln
4b20: 75 6d 20 31 29 29 29 29 0a 09 09 20 20 20 28 6d um 1))))... (m
4b30: 61 74 63 68 20 6d 6c 73 74 20 3b 3b 20 68 61 76 atch mlst ;; hav
4b40: 65 20 61 20 6e 6f 74 20 6e 75 6c 6c 20 6c 69 73 e a not null lis
4b50: 74 0a 09 09 20 20 20 20 20 28 28 5f 20 68 6f 73 t... ((_ hos
4b60: 74 20 70 6f 72 74 20 73 74 61 72 74 20 73 65 72 t port start ser
4b70: 76 65 72 2d 69 64 20 70 69 64 20 64 62 66 6e 61 ver-id pid dbfna
4b80: 6d 65 29 0a 09 09 20 20 20 20 20 20 28 6c 69 73 me)... (lis
4b90: 74 20 68 6f 73 74 0a 09 09 09 20 20 20 20 28 73 t host.... (s
4ba0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 6f tring->number po
4bb0: 72 74 29 0a 09 09 09 20 20 20 20 28 73 74 72 69 rt).... (stri
4bc0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 73 74 61 72 74 ng->number start
4bd0: 29 0a 09 09 09 20 20 20 20 73 65 72 76 65 72 2d ).... server-
4be0: 69 64 0a 09 09 09 20 20 20 20 28 73 74 72 69 6e id.... (strin
4bf0: 67 2d 3e 6e 75 6d 62 65 72 20 70 69 64 29 0a 09 g->number pid)..
4c00: 09 09 20 20 20 20 64 62 66 6e 61 6d 65 0a 09 09 .. dbfname...
4c10: 09 20 20 20 20 6c 6f 67 66 29 29 0a 09 09 20 20 . logf))...
4c20: 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 20 (else...
4c30: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
4c40: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
4c50: 74 2a 20 22 45 52 52 4f 52 3a 20 64 69 64 20 6e t* "ERROR: did n
4c60: 6f 74 20 72 65 63 6f 67 6e 69 73 65 20 53 45 52 ot recognise SER
4c70: 56 45 52 20 6c 69 6e 65 20 69 6e 66 6f 20 22 6d VER line info "m
4c80: 6c 73 74 29 0a 09 09 20 20 20 20 20 20 62 61 64 lst)... bad
4c90: 2d 64 61 74 29 29 29 29 29 29 29 29 29 0a 0a 3b -dat)))))))))..;
4ca0: 3b 20 47 69 76 65 6e 20 61 6e 20 61 72 65 61 20 ; Given an area
4cb0: 70 61 74 68 2c 20 20 73 74 61 72 74 20 61 20 73 path, start a s
4cc0: 65 72 76 65 72 20 70 72 6f 63 65 73 73 20 20 20 erver process
4cd0: 20 23 23 23 20 4e 4f 54 45 20 23 23 23 20 3e 20 ### NOTE ### >
4ce0: 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 69 66 file 2>&1 .;; if
4cf0: 20 74 68 65 20 74 61 72 67 65 74 2d 68 6f 73 74 the target-host
4d00: 20 69 73 20 73 65 74 20 0a 3b 3b 20 74 72 79 20 is set .;; try
4d10: 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 68 61 74 20 running on that
4d20: 68 6f 73 74 0a 3b 3b 20 20 20 69 6e 63 69 64 65 host.;; incide
4d30: 6e 74 61 6c 3a 20 72 6f 74 61 74 65 20 6c 6f 67 ntal: rotate log
4d40: 73 20 69 6e 20 6c 6f 67 73 2f 20 64 69 72 2e 0a s in logs/ dir..
4d50: 3b 3b 0a 28 64 65 66 69 6e 65 20 20 28 74 74 3a ;;.(define (tt:
4d60: 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 2d 72 server-process-r
4d70: 75 6e 20 61 72 65 61 70 61 74 68 20 74 65 73 74 un areapath test
4d80: 73 75 69 74 65 20 6d 74 65 78 65 20 72 75 6e 2d suite mtexe run-
4d90: 69 64 20 23 21 6b 65 79 20 28 70 72 6f 66 69 6c id #!key (profil
4da0: 65 2d 6d 6f 64 65 20 22 22 29 29 20 3b 3b 20 61 e-mode "")) ;; a
4db0: 72 65 61 70 61 74 68 20 69 73 20 2a 74 6f 70 70 reapath is *topp
4dc0: 61 74 68 2a 20 66 6f 72 20 61 20 67 69 76 65 6e ath* for a given
4dd0: 20 74 65 73 74 73 75 69 74 65 20 61 72 65 61 0a testsuite area.
4de0: 20 20 28 61 73 73 65 72 74 20 61 72 65 61 70 61 (assert areapa
4df0: 74 68 20 20 22 46 41 54 41 4c 3a 20 74 74 3a 73 th "FATAL: tt:s
4e00: 65 72 76 65 72 2d 70 72 6f 63 65 73 73 2d 72 75 erver-process-ru
4e10: 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 6f 75 74 n called without
4e20: 20 61 72 65 61 70 61 74 68 20 64 65 66 69 6e 65 areapath define
4e30: 64 2e 22 29 0a 20 20 28 61 73 73 65 72 74 20 74 d."). (assert t
4e40: 65 73 74 73 75 69 74 65 20 22 46 41 54 41 4c 3a estsuite "FATAL:
4e50: 20 74 74 3a 73 65 72 76 65 72 2d 70 72 6f 63 65 tt:server-proce
4e60: 73 73 2d 72 75 6e 20 63 61 6c 6c 65 64 20 77 69 ss-run called wi
4e70: 74 68 6f 75 74 20 74 65 73 74 73 75 69 74 65 20 thout testsuite
4e80: 64 65 66 69 6e 65 64 2e 22 29 0a 20 20 28 61 73 defined."). (as
4e90: 73 65 72 74 20 6d 74 65 78 65 20 20 20 20 20 22 sert mtexe "
4ea0: 46 41 54 41 4c 3a 20 74 74 3a 73 65 72 76 65 72 FATAL: tt:server
4eb0: 2d 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 61 6c -process-run cal
4ec0: 6c 65 64 20 77 69 74 68 6f 75 74 20 6d 74 65 78 led without mtex
4ed0: 65 20 64 65 66 69 6e 65 64 2e 22 29 0a 20 20 28 e defined."). (
4ee0: 6c 65 74 2a 20 28 28 6c 6f 61 64 20 28 67 65 74 let* ((load (get
4ef0: 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d -normalized-cpu-
4f00: 6c 6f 61 64 29 29 0a 09 20 28 6e 72 75 6e 20 28 load)).. (nrun (
4f10: 6e 75 6d 62 65 72 2d 6f 66 2d 70 72 6f 63 65 73 number-of-proces
4f20: 73 65 73 2d 72 75 6e 6e 69 6e 67 20 22 6d 74 65 ses-running "mte
4f30: 73 74 2e 2a 73 65 72 76 65 72 22 29 29 29 0a 20 st.*server"))).
4f40: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
4f50: 3e 20 6c 6f 61 64 20 32 2e 30 29 0a 20 20 20 20 > load 2.0).
4f60: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
4f70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4f80: 72 74 2a 20 22 4e 6f 72 6d 61 6c 69 7a 65 64 20 rt* "Normalized
4f90: 6c 6f 61 64 20 22 6c 6f 61 64 22 20 69 73 20 6f load "load" is o
4fa0: 76 65 72 20 74 68 65 20 6c 69 6d 69 74 20 6f 66 ver the limit of
4fb0: 20 32 2e 30 2e 20 4e 6f 74 20 73 74 61 72 74 69 2.0. Not starti
4fc0: 6e 67 20 61 20 73 65 72 76 65 72 2e 22 29 0a 20 ng a server.").
4fd0: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
4fe0: 65 70 21 20 31 29 29 0a 20 20 20 20 20 28 28 3e ep! 1)). ((>
4ff0: 20 6e 72 75 6e 20 34 30 29 0a 20 20 20 20 20 20 nrun 40).
5000: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
5010: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5020: 2a 20 6e 72 75 6e 22 20 73 65 72 76 65 72 73 20 * nrun" servers
5030: 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 68 69 73 20 running on this
5040: 68 6f 73 74 2c 20 6e 6f 74 20 73 74 61 72 74 69 host, not starti
5050: 6e 67 20 61 6e 6f 74 68 65 72 2e 22 29 0a 20 20 ng another.").
5060: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
5070: 70 21 20 31 29 29 0a 20 20 20 20 20 28 65 6c 73 p! 1)). (els
5080: 65 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 e. (if (not
5090: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 (file-exists? (
50a0: 63 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f 6c conc areapath"/l
50b0: 6f 67 73 22 29 29 29 0a 09 20 20 20 20 20 20 28 ogs"))).. (
50c0: 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 create-directory
50d0: 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 22 (conc areapath"
50e0: 2f 6c 6f 67 73 22 29 20 23 74 29 29 0a 09 20 20 /logs") #t))..
50f0: 28 6c 65 74 2a 20 28 28 6c 6f 67 66 69 6c 65 20 (let* ((logfile
5100: 20 20 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 (conc areapath
5110: 20 22 2f 6c 6f 67 73 2f 73 65 72 76 65 72 2e 6c "/logs/server.l
5120: 6f 67 22 29 29 20 3b 3b 20 2d 22 20 63 75 72 72 og")) ;; -" curr
5130: 2d 70 69 64 20 22 2d 22 20 74 61 72 67 65 74 2d -pid "-" target-
5140: 68 6f 73 74 20 22 2e 6c 6f 67 22 29 29 0a 09 09 host ".log"))...
5150: 20 28 63 6d 64 6c 6e 20 20 20 20 20 28 63 6f 6e (cmdln (con
5160: 63 0a 09 09 09 20 20 20 20 20 6d 74 65 78 65 0a c.... mtexe.
5170: 09 09 09 20 20 20 20 20 22 20 2d 73 65 72 76 65 ... " -serve
5180: 72 20 2d 20 22 3b 3b 20 28 6f 72 20 74 61 72 67 r - ";; (or targ
5190: 65 74 2d 68 6f 73 74 20 22 2d 22 29 0a 09 09 09 et-host "-")....
51a0: 20 20 20 20 20 22 20 2d 6d 20 74 65 73 74 73 75 " -m testsu
51b0: 69 74 65 3a 22 20 74 65 73 74 73 75 69 74 65 0a ite:" testsuite.
51c0: 09 09 09 20 20 20 20 20 3b 3b 20 22 20 2d 72 75 ... ;; " -ru
51d0: 6e 2d 69 64 20 22 20 28 6f 72 20 72 75 6e 2d 69 n-id " (or run-i
51e0: 64 20 22 6d 61 69 6e 22 29 20 3b 3b 20 4e 4f 2c d "main") ;; NO,
51f0: 20 77 65 20 64 6f 20 4e 4f 54 20 77 61 6e 74 20 we do NOT want
5200: 74 6f 20 68 61 76 65 20 72 75 6e 20 69 64 20 61 to have run id a
5210: 73 20 70 61 72 74 20 6f 66 20 74 68 69 73 0a 09 s part of this..
5220: 09 09 20 20 20 20 20 22 20 2d 64 62 20 22 20 20 .. " -db "
5230: 28 64 62 6d 6f 64 3a 72 75 6e 2d 69 64 2d 3e 64 (dbmod:run-id->d
5240: 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 29 0a 09 bfname run-id)..
5250: 09 09 20 20 20 20 20 22 20 22 20 70 72 6f 66 69 .. " " profi
5260: 6c 65 2d 6d 6f 64 65 0a 09 09 09 20 20 20 20 20 le-mode....
5270: 29 29 29 20 3b 3b 20 28 63 6f 6e 63 20 22 20 3e ))) ;; (conc " >
5280: 3e 20 22 20 6c 6f 67 66 69 6c 65 20 22 20 32 3e > " logfile " 2>
5290: 26 31 20 26 22 29 29 29 29 29 0a 09 20 20 20 20 &1 &")))))..
52a0: 3b 3b 20 77 65 20 77 61 6e 74 20 74 68 65 20 72 ;; we want the r
52b0: 65 6d 6f 74 65 20 73 65 72 76 65 72 20 74 6f 20 emote server to
52c0: 73 74 61 72 74 20 69 6e 20 2a 74 6f 70 70 61 74 start in *toppat
52d0: 68 2a 20 73 6f 20 70 75 73 68 20 74 68 65 72 65 h* so push there
52e0: 0a 09 20 20 20 20 3b 3b 20 28 70 75 73 68 2d 64 .. ;; (push-d
52f0: 69 72 65 63 74 6f 72 79 20 61 72 65 61 70 61 74 irectory areapat
5300: 68 29 20 3b 3b 20 75 73 65 20 63 64 20 69 6e 20 h) ;; use cd in
5310: 74 68 65 20 63 6f 6d 6d 61 6e 64 20 6c 69 6e 65 the command line
5320: 20 69 6e 73 74 65 61 64 0a 09 20 20 20 20 28 64 instead.. (d
5330: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
5340: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5350: 22 49 4e 46 4f 3a 20 54 72 79 69 6e 67 20 74 6f "INFO: Trying to
5360: 20 73 74 61 72 74 20 73 65 72 76 65 72 20 69 6e start server in
5370: 20 74 63 70 20 6d 6f 64 65 20 28 22 20 63 6d 64 tcp mode (" cmd
5380: 6c 6e 20 22 29 20 61 74 20 22 28 63 6f 6d 6d 6f ln ") at "(commo
5390: 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 22 2e 2e n:human-time)"..
53a0: 2e 22 29 0a 09 20 20 20 20 3b 3b 20 28 64 65 62 .").. ;; (deb
53b0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
53c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
53d0: 4e 46 4f 3a 20 73 74 61 72 74 69 6e 67 20 73 65 NFO: starting se
53e0: 72 76 65 72 20 61 74 20 22 20 28 63 6f 6d 6d 6f rver at " (commo
53f0: 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 29 0a 09 n:human-time))..
5400: 20 20 20 20 28 73 65 74 65 6e 76 20 22 4e 42 46 (setenv "NBF
5410: 41 4b 45 5f 51 55 49 45 54 22 20 22 79 65 73 22 AKE_QUIET" "yes"
5420: 29 20 3b 3b 20 42 55 47 3a 20 63 68 61 6e 67 65 ) ;; BUG: change
5430: 20 74 6f 20 77 69 74 68 2d 65 6e 76 69 72 6f 6e to with-environ
5440: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 2e 2e ment-variable ..
5450: 2e 0a 09 20 20 20 20 28 73 65 74 65 6e 76 20 22 ... (setenv "
5460: 4e 42 46 41 4b 45 5f 4c 4f 47 22 20 6c 6f 67 66 NBFAKE_LOG" logf
5470: 69 6c 65 29 0a 09 20 20 20 20 28 73 79 73 74 65 ile).. (syste
5480: 6d 20 28 63 6f 6e 63 20 22 63 64 20 22 61 72 65 m (conc "cd "are
5490: 61 70 61 74 68 22 20 3b 20 6e 62 66 61 6b 65 20 apath" ; nbfake
54a0: 22 20 63 6d 64 6c 6e 29 29 0a 09 20 20 20 20 28 " cmdln)).. (
54b0: 75 6e 73 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 unsetenv "NBFAKE
54c0: 5f 51 55 49 45 54 22 29 0a 09 20 20 20 20 28 75 _QUIET").. (u
54d0: 6e 73 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 5f nsetenv "NBFAKE_
54e0: 4c 4f 47 22 29 0a 09 20 20 20 20 3b 3b 28 70 6f LOG").. ;;(po
54f0: 70 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 20 20 p-directory)..
5500: 20 20 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))..;;=====
5510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5550: 3d 0a 3b 3b 20 74 63 70 20 63 6f 6e 6e 65 63 74 =.;; tcp connect
5560: 69 6f 6e 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d ion stuff.;;====
5570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55b0: 3d 3d 0a 0a 3b 3b 20 66 69 6e 64 20 61 20 70 6f ==..;; find a po
55c0: 72 74 20 61 6e 64 20 73 74 61 72 74 20 74 63 70 rt and start tcp
55d0: 2d 73 65 72 76 65 72 2e 20 54 68 69 73 20 6f 6e -server. This on
55e0: 6c 79 20 73 74 61 72 74 73 20 74 68 65 20 74 63 ly starts the tc
55f0: 70 20 70 6f 72 74 69 6f 6e 20 6f 66 0a 3b 3b 20 p portion of.;;
5600: 74 68 65 20 73 65 72 76 65 72 2c 20 6c 6f 6f 6b the server, look
5610: 20 61 74 20 28 74 74 3a 73 74 61 72 74 2d 73 65 at (tt:start-se
5620: 72 76 65 72 20 2e 2e 2e 29 20 61 62 6f 76 65 20 rver ...) above
5630: 66 6f 72 20 74 68 65 20 65 6e 74 72 79 20 70 6f for the entry po
5640: 69 6e 74 0a 3b 3b 20 66 6f 72 20 74 68 65 20 65 int.;; for the e
5650: 6e 74 69 72 65 20 73 65 72 76 65 72 20 73 79 73 ntire server sys
5660: 74 65 6d 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 tem.;;.(define (
5670: 74 74 3a 73 74 61 72 74 2d 74 63 70 2d 73 65 72 tt:start-tcp-ser
5680: 76 65 72 20 74 74 64 61 74 29 0a 20 20 28 73 65 ver ttdat). (se
5690: 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 74 74 64 tup-listener ttd
56a0: 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 6f at). (let* ((so
56b0: 63 6b 65 74 20 20 20 28 74 74 2d 73 6f 63 6b 65 cket (tt-socke
56c0: 74 20 20 74 74 64 61 74 29 29 0a 09 20 28 68 61 t ttdat)).. (ha
56d0: 6e 64 6c 65 72 20 20 28 74 74 2d 68 61 6e 64 6c ndler (tt-handl
56e0: 65 72 20 74 74 64 61 74 29 29 29 0a 20 20 20 20 er ttdat))).
56f0: 28 28 6d 61 6b 65 2d 74 63 70 2d 73 65 72 76 65 ((make-tcp-serve
5700: 72 20 73 6f 63 6b 65 74 20 68 61 6e 64 6c 65 72 r socket handler
5710: 29 0a 20 20 20 20 20 23 74 20 3b 3b 20 79 65 73 ). #t ;; yes
5720: 2c 20 73 65 6e 64 20 65 72 72 6f 72 20 6d 65 73 , send error mes
5730: 73 61 67 65 73 20 74 6f 20 73 74 64 2d 65 72 72 sages to std-err
5740: 0a 20 20 20 20 20 29 29 29 0a 0a 3b 3b 20 63 72 . )))..;; cr
5750: 65 61 74 65 20 61 20 74 63 70 20 6c 69 73 74 65 eate a tcp liste
5760: 6e 65 72 20 61 6e 64 20 72 65 74 75 72 6e 20 61 ner and return a
5770: 20 70 6f 70 75 6c 61 74 65 64 20 75 64 61 74 20 populated udat
5780: 73 74 72 75 63 74 20 77 69 74 68 0a 3b 3b 20 6d struct with.;; m
5790: 79 20 70 6f 72 74 2c 20 61 64 64 72 65 73 73 2c y port, address,
57a0: 20 68 6f 73 74 6e 61 6d 65 2c 20 70 69 64 20 65 hostname, pid e
57b0: 74 63 2e 0a 3b 3b 20 72 65 74 75 72 6e 20 23 66 tc..;; return #f
57c0: 20 69 66 20 66 61 69 6c 20 74 6f 20 66 69 6e 64 if fail to find
57d0: 20 61 20 70 6f 72 74 20 74 6f 20 61 6c 6c 6f 63 a port to alloc
57e0: 61 74 65 2e 0a 3b 3b 0a 3b 3b 20 20 69 66 20 75 ate..;;.;; if u
57f0: 64 61 74 61 2d 69 6e 20 69 73 20 23 66 20 63 72 data-in is #f cr
5800: 65 61 74 65 20 74 68 65 20 72 65 63 6f 72 64 0a eate the record.
5810: 3b 3b 20 20 69 66 20 74 68 65 72 65 20 69 73 20 ;; if there is
5820: 61 6c 72 65 61 64 79 20 61 20 73 65 72 76 2d 6c already a serv-l
5830: 69 73 74 65 6e 65 72 20 72 65 74 75 72 6e 20 74 istener return t
5840: 68 65 20 75 64 61 74 61 0a 3b 3b 0a 28 64 65 66 he udata.;;.(def
5850: 69 6e 65 20 28 73 65 74 75 70 2d 6c 69 73 74 65 ine (setup-liste
5860: 6e 65 72 20 75 63 6f 6e 6e 20 23 21 6f 70 74 69 ner uconn #!opti
5870: 6f 6e 61 6c 20 28 70 6f 72 74 20 34 32 34 32 29 onal (port 4242)
5880: 29 0a 20 20 28 61 73 73 65 72 74 20 28 74 74 3f ). (assert (tt?
5890: 20 75 63 6f 6e 6e 29 20 22 46 41 54 41 4c 3a 20 uconn) "FATAL:
58a0: 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 63 setup-listener c
58b0: 61 6c 6c 65 64 20 77 69 74 68 20 77 72 6f 6e 67 alled with wrong
58c0: 20 73 74 72 75 63 74 20 22 75 63 6f 6e 6e 29 0a struct "uconn).
58d0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
58e0: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 ions. exn. (
58f0: 69 66 20 28 3c 20 70 6f 72 74 20 36 35 35 33 35 if (< port 65535
5900: 29 0a 20 20 20 20 20 20 20 28 73 65 74 75 70 2d ). (setup-
5910: 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e 6e 20 28 listener uconn (
5920: 2b 20 70 6f 72 74 20 31 29 29 0a 20 20 20 20 20 + port 1)).
5930: 20 20 23 66 29 0a 20 20 20 28 63 6f 6e 6e 65 63 #f). (connec
5940: 74 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e 6e t-listener uconn
5950: 20 70 6f 72 74 29 29 29 0a 0a 28 64 65 66 69 6e port)))..(defin
5960: 65 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 74 65 e (connect-liste
5970: 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 29 0a ner uconn port).
5980: 20 20 3b 3b 20 28 74 63 70 2d 6c 69 73 74 65 6e ;; (tcp-listen
5990: 65 72 2d 73 6f 63 6b 65 74 20 4c 49 53 54 45 4e er-socket LISTEN
59a0: 45 52 29 28 73 6f 63 6b 65 74 2d 6e 61 6d 65 20 ER)(socket-name
59b0: 73 6f 29 0a 20 20 3b 3b 20 73 6f 63 6b 61 64 64 so). ;; sockadd
59c0: 72 2d 61 64 64 72 65 73 73 2c 20 73 6f 63 6b 61 r-address, socka
59d0: 64 64 72 2d 70 6f 72 74 2c 20 73 6f 63 6b 61 64 ddr-port, sockad
59e0: 64 72 2d 3e 73 74 72 69 6e 67 0a 20 20 28 6c 65 dr->string. (le
59f0: 74 2a 20 28 28 74 6c 73 6e 20 28 74 63 70 2d 6c t* ((tlsn (tcp-l
5a00: 69 73 74 65 6e 20 70 6f 72 74 20 31 30 30 30 20 isten port 1000
5a10: 23 66 29 29 20 3b 3b 20 28 74 63 70 2d 6c 69 73 #f)) ;; (tcp-lis
5a20: 74 65 6e 20 54 43 50 50 4f 52 54 20 5b 42 41 43 ten TCPPORT [BAC
5a30: 4b 4c 4f 47 20 5b 48 4f 53 54 5d 5d 29 0a 09 20 KLOG [HOST]])..
5a40: 28 61 64 64 72 20 20 28 74 74 3a 67 65 74 2d 62 (addr (tt:get-b
5a50: 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 est-guess-addres
5a60: 73 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 s (get-host-name
5a70: 29 29 29 29 20 3b 3b 20 28 67 65 74 2d 6d 79 2d )))) ;; (get-my-
5a80: 62 65 73 74 2d 61 64 64 72 65 73 73 29 29 29 20 best-address)))
5a90: 3b 3b 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 ;; (hostinfo-add
5aa0: 72 65 73 73 65 73 20 28 68 6f 73 74 2d 69 6e 66 resses (host-inf
5ab0: 6f 72 6d 61 74 69 6f 6e 20 28 63 75 72 72 65 6e ormation (curren
5ac0: 74 2d 68 6f 73 74 6e 61 6d 65 29 29 29 0a 20 20 t-hostname))).
5ad0: 20 20 28 74 74 2d 70 6f 72 74 2d 73 65 74 21 20 (tt-port-set!
5ae0: 20 20 20 20 20 75 63 6f 6e 6e 20 70 6f 72 74 29 uconn port)
5af0: 0a 20 20 20 20 28 74 74 2d 68 6f 73 74 2d 73 65 . (tt-host-se
5b00: 74 21 20 20 20 20 20 20 75 63 6f 6e 6e 20 61 64 t! uconn ad
5b10: 64 72 29 0a 20 20 20 20 28 74 74 2d 68 6f 73 74 dr). (tt-host
5b20: 2d 70 6f 72 74 2d 73 65 74 21 20 75 63 6f 6e 6e -port-set! uconn
5b30: 20 28 63 6f 6e 63 20 61 64 64 72 22 3a 22 70 6f (conc addr":"po
5b40: 72 74 29 29 0a 20 20 20 20 28 74 74 2d 73 6f 63 rt)). (tt-soc
5b50: 6b 65 74 2d 73 65 74 21 20 20 20 20 75 63 6f 6e ket-set! ucon
5b60: 6e 20 74 6c 73 6e 29 0a 20 20 20 20 75 63 6f 6e n tlsn). ucon
5b70: 6e 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d n))..;;=========
5b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
5bc0: 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d utils.;;=======
5bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
5c10: 0a 3b 3b 20 47 65 6e 65 72 61 74 65 20 61 20 75 .;; Generate a u
5c20: 6e 69 71 75 65 20 73 69 67 6e 61 74 75 72 65 20 nique signature
5c30: 66 6f 72 20 74 68 69 73 20 73 65 72 76 65 72 0a for this server.
5c40: 28 64 65 66 69 6e 65 20 28 74 74 3a 6d 6b 2d 73 (define (tt:mk-s
5c50: 69 67 6e 61 74 75 72 65 20 61 72 65 61 70 61 74 ignature areapat
5c60: 68 29 0a 20 20 28 6d 65 73 73 61 67 65 2d 64 69 h). (message-di
5c70: 67 65 73 74 2d 73 74 72 69 6e 67 20 28 6d 64 35 gest-string (md5
5c80: 2d 70 72 69 6d 69 74 69 76 65 29 20 0a 09 09 09 -primitive) ....
5c90: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
5ca0: 2d 73 74 72 69 6e 67 0a 09 09 09 20 20 20 28 6c -string.... (l
5cb0: 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 ambda ()....
5cc0: 20 28 77 72 69 74 65 20 28 6c 69 73 74 20 61 72 (write (list ar
5cd0: 65 61 70 61 74 68 0a 20 20 20 20 20 20 20 20 20 eapath.
5ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d00: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
5d10: 73 2d 69 64 29 0a 09 09 09 09 09 20 20 28 61 72 s-id)...... (ar
5d20: 67 76 29 29 29 29 29 29 29 0a 0a 0a 28 64 65 66 gv)))))))...(def
5d30: 69 6e 65 20 28 74 74 3a 67 65 74 2d 62 65 73 74 ine (tt:get-best
5d40: 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 -guess-address h
5d50: 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 ostname). (let
5d60: 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 ((res #f)). (
5d70: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
5d80: 6c 61 6d 62 64 61 20 28 61 64 72 29 0a 20 20 20 lambda (adr).
5d90: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
5da0: 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 65 66 20 ? (u8vector-ref
5db0: 61 64 72 20 30 29 20 31 32 37 29 29 0a 09 20 20 adr 0) 127))..
5dc0: 20 28 73 65 74 21 20 72 65 73 20 61 64 72 29 29 (set! res adr))
5dd0: 29 0a 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 ). ;; NOTE:
5de0: 54 68 69 73 20 63 61 6e 20 66 61 69 6c 20 77 68 This can fail wh
5df0: 65 6e 20 74 68 65 72 65 20 69 73 20 6e 6f 20 6d en there is no m
5e00: 65 6e 74 69 6f 6e 20 6f 66 20 74 68 65 20 68 6f ention of the ho
5e10: 73 74 20 69 6e 20 2f 65 74 63 2f 68 6f 73 74 73 st in /etc/hosts
5e20: 2e 20 46 49 58 4d 45 0a 20 20 20 20 20 28 76 65 . FIXME. (ve
5e30: 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 ctor->list (host
5e40: 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 info-addresses (
5e50: 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e hostname->hostin
5e60: 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a fo hostname)))).
5e70: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
5e80: 72 73 70 65 72 73 65 20 0a 20 20 20 20 20 28 6d rsperse . (m
5e90: 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e ap number->strin
5ea0: 67 0a 09 20 20 28 75 38 76 65 63 74 6f 72 2d 3e g.. (u8vector->
5eb0: 6c 69 73 74 0a 09 20 20 20 28 69 66 20 72 65 73 list.. (if res
5ec0: 20 72 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e res (hostname->
5ed0: 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 ip hostname))))
5ee0: 22 2e 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ".")))..(define
5ef0: 28 74 74 3a 67 65 74 2d 73 65 72 76 69 6e 66 6f (tt:get-servinfo
5f00: 2d 64 69 72 20 61 72 65 61 70 61 74 68 29 0a 20 -dir areapath).
5f10: 20 28 6c 65 74 2a 20 28 28 73 70 61 74 68 20 28 (let* ((spath (
5f20: 63 6f 6e 63 20 61 72 65 61 70 61 74 68 22 2f 2e conc areapath"/.
5f30: 73 65 72 76 69 6e 66 6f 22 29 29 29 0a 20 20 20 servinfo"))).
5f40: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
5f50: 65 78 69 73 74 73 3f 20 73 70 61 74 68 29 29 0a exists? spath)).
5f60: 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f .(create-directo
5f70: 72 79 20 73 70 61 74 68 20 23 74 29 29 0a 20 20 ry spath #t)).
5f80: 20 20 73 70 61 74 68 29 29 0a 0a 3b 3b 3d 3d 3d spath))..;;===
5f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fd0: 3d 3d 3d 0a 3b 3b 20 6e 65 74 77 6f 72 6b 20 75 ===.;; network u
5fe0: 74 69 6c 69 74 69 65 73 0a 3b 3b 3d 3d 3d 3d 3d tilities.;;=====
5ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6030: 3d 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 4c 6f 6f 6b =..;; NOTE: Look
6040: 20 61 74 20 61 64 64 72 65 73 73 2d 69 6e 66 6f at address-info
6050: 20 65 67 67 20 61 73 20 61 6c 74 65 72 6e 61 74 egg as alternat
6060: 69 76 65 20 74 6f 20 73 6f 6d 65 20 6f 66 20 74 ive to some of t
6070: 68 69 73 0a 0a 28 64 65 66 69 6e 65 20 28 72 61 his..(define (ra
6080: 74 65 2d 69 70 20 69 70 61 64 64 72 29 0a 20 20 te-ip ipaddr).
6090: 28 72 65 67 65 78 2d 63 61 73 65 20 69 70 61 64 (regex-case ipad
60a0: 64 72 0a 20 20 20 20 28 20 22 5e 31 32 37 5c 5c dr. ( "^127\\
60b0: 2e 2e 2a 22 20 5f 20 30 20 29 0a 20 20 20 20 28 ..*" _ 0 ). (
60c0: 20 22 5e 28 31 30 5c 5c 2e 30 7c 31 39 32 5c 5c "^(10\\.0|192\\
60d0: 2e 31 36 38 29 5c 5c 2e 2e 2a 22 20 5f 20 31 20 .168)\\..*" _ 1
60e0: 29 0a 20 20 20 20 28 20 65 6c 73 65 20 32 20 29 ). ( else 2 )
60f0: 20 29 29 0a 0a 3b 3b 20 43 68 61 6e 67 65 20 74 ))..;; Change t
6100: 68 69 73 20 74 6f 20 62 69 61 73 20 66 6f 72 20 his to bias for
6110: 61 64 64 72 65 73 73 65 73 20 77 69 74 68 20 61 addresses with a
6120: 20 72 65 61 73 6f 6e 61 62 6c 65 20 62 72 6f 61 reasonable broa
6130: 64 63 61 73 74 20 76 61 6c 75 65 3f 0a 3b 3b 0a dcast value?.;;.
6140: 28 64 65 66 69 6e 65 20 28 69 70 2d 70 72 65 66 (define (ip-pref
6150: 2d 6c 65 73 73 3f 20 61 20 62 29 0a 20 20 28 3e -less? a b). (>
6160: 20 28 72 61 74 65 2d 69 70 20 61 29 20 28 72 61 (rate-ip a) (ra
6170: 74 65 2d 69 70 20 62 29 29 29 0a 0a 28 64 65 66 te-ip b)))..(def
6180: 69 6e 65 20 28 67 65 74 2d 6d 79 2d 62 65 73 74 ine (get-my-best
6190: 2d 61 64 64 72 65 73 73 29 0a 20 20 28 6c 65 74 -address). (let
61a0: 20 28 28 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 ((all-my-addres
61b0: 73 65 73 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 ses (get-all-ips
61c0: 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 ))). (cond.
61d0: 20 20 20 28 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d ((null? all-m
61e0: 79 2d 61 64 64 72 65 73 73 65 73 29 0a 20 20 20 y-addresses).
61f0: 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d (get-host-nam
6200: 65 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 e))
6210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6220: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
6230: 6e 6f 20 69 6e 74 65 72 66 61 63 65 73 3f 0a 20 no interfaces?.
6240: 20 20 20 20 28 28 65 71 3f 20 28 6c 65 6e 67 74 ((eq? (lengt
6250: 68 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 h all-my-address
6260: 65 73 29 20 31 29 0a 20 20 20 20 20 20 28 63 61 es) 1). (ca
6270: 72 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 r all-my-address
6280: 65 73 29 29 20 20 20 20 20 20 20 20 20 20 20 20 es))
6290: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 6e 6c ;; onl
62a0: 79 20 6f 6e 65 20 74 6f 20 63 68 6f 6f 73 65 20 y one to choose
62b0: 66 72 6f 6d 2c 20 6a 75 73 74 20 67 6f 20 77 69 from, just go wi
62c0: 74 68 20 69 74 0a 20 20 20 20 20 28 65 6c 73 65 th it. (else
62d0: 0a 20 20 20 20 20 20 28 63 61 72 20 28 73 6f 72 . (car (sor
62e0: 74 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 t all-my-address
62f0: 65 73 20 69 70 2d 70 72 65 66 2d 6c 65 73 73 3f es ip-pref-less?
6300: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
6310: 28 67 65 74 2d 61 6c 6c 2d 69 70 73 2d 73 6f 72 (get-all-ips-sor
6320: 74 65 64 29 0a 20 20 28 73 6f 72 74 20 28 67 65 ted). (sort (ge
6330: 74 2d 61 6c 6c 2d 69 70 73 29 20 69 70 2d 70 72 t-all-ips) ip-pr
6340: 65 66 2d 6c 65 73 73 3f 29 29 0a 0a 28 64 65 66 ef-less?))..(def
6350: 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 ine (get-all-ips
6360: 29 0a 20 20 28 6d 61 70 20 61 64 64 72 65 73 73 ). (map address
6370: 2d 69 6e 66 6f 2d 68 6f 73 74 0a 20 20 20 20 20 -info-host.
6380: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
6390: 61 20 28 78 29 0a 09 09 20 28 65 71 75 61 6c 3f a (x)... (equal?
63a0: 20 28 61 64 64 72 65 73 73 2d 69 6e 66 6f 2d 74 (address-info-t
63b0: 79 70 65 20 78 29 20 22 74 63 70 22 29 29 0a 09 ype x) "tcp"))..
63c0: 20 20 20 20 20 20 20 28 61 64 64 72 65 73 73 2d (address-
63d0: 69 6e 66 6f 73 20 28 67 65 74 2d 68 6f 73 74 2d infos (get-host-
63e0: 6e 61 6d 65 29 29 29 29 29 0a 0a 29 0a name)))))..).