Artifact
d835b7f23aab40d3304d02a6b4fbc4bb35cdec00:
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 6c 61 73 74 2d 61 63 63 65 73 73 20 . (last-access
08a0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
08b0: 73 29 29 0a 20 20 29 0a 0a 28 64 65 66 69 6e 65 s)). )..(define
08c0: 20 28 74 74 3a 6d 61 6b 65 2d 72 65 6d 6f 74 65 (tt:make-remote
08d0: 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 6d 61 areapath). (ma
08e0: 6b 65 2d 74 74 20 61 72 65 61 3a 20 61 72 65 61 ke-tt area: area
08f0: 70 61 74 68 29 29 0a 0a 3b 3b 20 64 6f 20 61 6c path))..;; do al
0900: 6c 20 74 68 65 20 62 75 73 79 20 77 6f 72 6b 20 l the busy work
0910: 6f 66 20 66 69 6e 64 69 6e 67 20 61 6e 64 20 73 of finding and s
0920: 65 74 74 69 6e 67 20 75 70 20 63 6f 6e 6e 20 66 etting up conn f
0930: 6f 72 0a 3b 3b 20 63 6f 6e 6e 65 63 74 69 6e 67 or.;; connecting
0940: 20 74 6f 20 61 20 73 65 72 76 65 72 0a 3b 3b 20 to a server.;;
0950: 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 63 6c 69 .(define (tt:cli
0960: 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 ent-connect-to-s
0970: 65 72 76 65 72 20 74 74 64 61 74 20 64 62 66 6e erver ttdat dbfn
0980: 61 6d 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c ame run-id). (l
0990: 65 74 2a 20 28 28 63 6f 6e 6e 20 28 68 61 73 68 et* ((conn (hash
09a0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
09b0: 6c 74 20 28 74 74 2d 63 6f 6e 6e 73 20 74 74 64 lt (tt-conns ttd
09c0: 61 74 29 20 64 62 66 6e 61 6d 65 20 23 66 29 29 at) dbfname #f))
09d0: 29 0a 20 20 20 20 28 69 66 20 63 6f 6e 6e 0a 09 ). (if conn..
09e0: 63 6f 6e 6e 20 3b 3b 20 77 65 20 61 72 65 20 61 conn ;; we are a
09f0: 6c 72 65 61 64 79 20 63 6f 6e 6e 65 63 74 65 64 lready connected
0a00: 20 74 6f 20 74 68 65 20 73 65 72 76 65 72 0a 09 to the server..
0a10: 28 6c 65 74 2a 20 28 28 73 64 61 74 20 28 74 74 (let* ((sdat (tt
0a20: 3a 67 65 74 2d 63 75 72 72 65 6e 74 2d 73 65 72 :get-current-ser
0a30: 76 65 72 2d 69 6e 66 6f 20 74 74 64 61 74 20 64 ver-info ttdat d
0a40: 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 29 29 29 bfname run-id)))
0a50: 0a 09 20 20 28 6d 61 74 63 68 20 73 64 61 74 0a .. (match sdat.
0a60: 09 20 20 20 20 28 28 68 6f 73 74 20 70 6f 72 74 . ((host port
0a70: 20 73 74 61 72 74 2d 74 69 6d 65 20 73 65 72 76 start-time serv
0a80: 65 72 2d 69 64 20 70 69 64 29 0a 09 20 20 20 20 er-id pid)..
0a90: 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 28 6d 61 (let ((conn (ma
0aa0: 6b 65 2d 74 74 2d 63 6f 6e 6e 0a 09 09 09 20 20 ke-tt-conn....
0ab0: 68 6f 73 74 3a 20 68 6f 73 74 0a 09 09 09 20 20 host: host....
0ac0: 70 6f 72 74 3a 20 70 6f 72 74 0a 09 09 09 20 20 port: port....
0ad0: 64 62 66 6e 61 6d 65 3a 20 64 62 66 6e 61 6d 65 dbfname: dbfname
0ae0: 0a 09 09 09 20 20 73 65 72 76 65 72 2d 69 64 3a .... server-id:
0af0: 20 73 65 72 76 65 72 2d 69 64 0a 09 09 09 20 20 server-id....
0b00: 73 65 72 76 65 72 2d 73 74 61 72 74 3a 20 73 74 server-start: st
0b10: 61 72 74 2d 74 69 6d 65 0a 09 09 09 20 20 70 69 art-time.... pi
0b20: 64 3a 20 70 69 64 29 29 29 0a 09 20 20 20 20 20 d: pid)))..
0b30: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
0b40: 74 21 20 28 74 74 2d 63 6f 6e 6e 73 20 74 74 64 t! (tt-conns ttd
0b50: 61 74 29 20 64 62 66 6e 61 6d 65 20 63 6f 6e 6e at) dbfname conn
0b60: 29 0a 09 20 20 20 20 20 20 20 63 6f 6e 6e 29 29 ).. conn))
0b70: 0a 09 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 .. (else..
0b80: 20 20 28 74 74 3a 73 65 72 76 65 72 2d 70 72 6f (tt:server-pro
0b90: 63 65 73 73 2d 72 75 6e 0a 09 20 20 20 20 20 20 cess-run..
0ba0: 28 74 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 (tt-areapath ttd
0bb0: 61 74 29 0a 09 20 20 20 20 20 20 28 64 62 66 69 at).. (dbfi
0bc0: 6c 65 3a 74 65 73 74 73 75 69 74 65 2d 6e 61 6d le:testsuite-nam
0bd0: 65 29 0a 09 20 20 20 20 20 20 28 63 6f 6d 6d 6f e).. (commo
0be0: 6e 3a 66 69 6e 64 2d 6c 6f 63 61 6c 2d 6d 65 67 n:find-local-meg
0bf0: 61 74 65 73 74 29 0a 09 20 20 20 20 20 20 72 75 atest).. ru
0c00: 6e 2d 69 64 29 0a 09 20 20 20 20 20 28 74 68 72 n-id).. (thr
0c10: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 20 ead-sleep! 1)..
0c20: 20 20 20 20 28 74 74 3a 63 6c 69 65 6e 74 2d 63 (tt:client-c
0c30: 6f 6e 6e 65 63 74 2d 74 6f 2d 73 65 72 76 65 72 onnect-to-server
0c40: 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 20 72 ttdat dbfname r
0c50: 75 6e 2d 69 64 29 29 29 29 29 29 29 0a 0a 3b 3b un-id)))))))..;;
0c60: 20 63 6c 69 65 6e 74 20 73 69 64 65 20 68 61 6e client side han
0c70: 64 6c 65 72 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 dler.;;.(define
0c80: 28 74 74 3a 68 61 6e 64 6c 65 72 20 74 74 64 61 (tt:handler ttda
0c90: 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 t cmd run-id par
0ca0: 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 20 61 ams attemptnum a
0cb0: 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 68 rea-dat areapath
0cc0: 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 readonly-mode d
0cd0: 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 65 bfname testsuite
0ce0: 20 6d 74 65 78 65 29 0a 20 20 3b 3b 20 4e 4f 54 mtexe). ;; NOT
0cf0: 45 3a 20 61 72 65 61 70 61 74 68 20 69 73 20 70 E: areapath is p
0d00: 61 73 73 65 64 20 69 6e 20 61 6e 64 20 69 6e 20 assed in and in
0d10: 74 74 20 73 74 72 75 63 74 2e 20 57 65 27 6c 6c tt struct. We'll
0d20: 20 75 73 65 20 70 61 73 73 65 64 20 69 6e 20 76 use passed in v
0d30: 61 6c 75 65 20 66 6f 72 20 6e 6f 77 2e 0a 20 20 alue for now..
0d40: 28 6c 65 74 2a 20 28 28 63 6f 6e 6e 20 28 74 74 (let* ((conn (tt
0d50: 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d :client-connect-
0d60: 74 6f 2d 73 65 72 76 65 72 20 74 74 64 61 74 20 to-server ttdat
0d70: 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 29 29 dbfname run-id))
0d80: 29 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 ) ;; (hash-table
0d90: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 74 74 -ref/default (tt
0da0: 2d 63 6f 6e 6e 73 20 74 74 64 61 74 29 20 64 62 -conns ttdat) db
0db0: 66 6e 61 6d 65 20 23 66 29 29 29 0a 20 20 20 20 fname #f))).
0dc0: 28 69 66 20 63 6f 6e 6e 0a 09 3b 3b 20 68 61 76 (if conn..;; hav
0dd0: 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 2c 20 63 61 e connection, ca
0de0: 6c 6c 20 74 68 65 20 73 65 72 76 65 72 0a 09 28 ll the server..(
0df0: 6c 65 74 2a 20 28 28 72 65 73 20 28 74 74 3a 73 let* ((res (tt:s
0e00: 65 6e 64 2d 72 65 63 65 69 76 65 20 74 74 64 61 end-receive ttda
0e10: 74 20 63 6f 6e 6e 20 63 6d 64 20 72 75 6e 2d 69 t conn cmd run-i
0e20: 64 20 70 61 72 61 6d 73 29 29 29 0a 09 20 20 28 d params))).. (
0e30: 63 6f 6e 64 0a 09 20 20 20 28 28 6d 65 6d 62 65 cond.. ((membe
0e40: 72 20 72 65 73 20 27 28 62 75 73 79 20 73 74 61 r res '(busy sta
0e50: 72 74 69 6e 67 29 29 0a 09 20 20 20 20 28 74 68 rting)).. (th
0e60: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 read-sleep! 1)..
0e70: 20 20 20 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 (tt:handler
0e80: 20 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 ttdat cmd run-i
0e90: 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 d params attempt
0ea0: 6e 75 6d 20 61 72 65 61 2d 64 61 74 20 61 72 65 num area-dat are
0eb0: 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d apath readonly-m
0ec0: 6f 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 74 ode dbfname test
0ed0: 73 75 69 74 65 20 6d 74 65 78 65 29 29 0a 09 20 suite mtexe))..
0ee0: 20 20 28 65 6c 73 65 0a 09 20 20 20 20 72 65 73 (else.. res
0ef0: 29 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 )))..(begin.. (
0f00: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
0f10: 20 3b 3b 20 67 69 76 65 20 69 74 20 61 20 72 65 ;; give it a re
0f20: 73 74 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e st and try again
0f30: 0a 09 20 20 28 74 74 3a 68 61 6e 64 6c 65 72 20 .. (tt:handler
0f40: 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 64 ttdat cmd run-id
0f50: 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e params attemptn
0f60: 75 6d 20 61 72 65 61 2d 64 61 74 20 61 72 65 61 um area-dat area
0f70: 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f path readonly-mo
0f80: 64 65 20 64 62 66 6e 61 6d 65 20 74 65 73 74 73 de dbfname tests
0f90: 75 69 74 65 20 6d 74 65 78 65 29 29 29 29 29 0a uite mtexe))))).
0fa0: 0a 09 3b 3b 20 6e 6f 20 63 6f 6e 6e 20 79 65 74 ..;; no conn yet
0fb0: 2c 20 66 69 6e 64 20 61 6e 64 20 6f 72 20 73 74 , find and or st
0fc0: 61 72 74 20 61 6e 64 20 66 69 6e 64 20 61 20 73 art and find a s
0fd0: 65 72 76 65 72 0a 3b 3b 20 09 28 6c 65 74 2a 20 erver.;; .(let*
0fe0: 28 28 73 65 72 76 65 72 20 28 74 74 3a 66 69 6e ((server (tt:fin
0ff0: 64 2d 73 65 72 76 65 72 20 74 74 64 61 74 20 64 d-server ttdat d
1000: 62 66 6e 61 6d 65 29 29 29 0a 3b 3b 20 09 20 20 bfname))).;; .
1010: 28 69 66 20 73 65 72 76 65 72 0a 3b 3b 20 09 20 (if server.;; .
1020: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e (let* ((con
1030: 6e 20 28 74 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e n (tt:client-con
1040: 6e 65 63 74 2d 74 6f 2d 73 65 72 76 65 72 20 73 nect-to-server s
1050: 65 72 76 65 72 29 29 29 0a 3b 3b 20 09 09 28 68 erver))).;; ..(h
1060: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
1070: 74 74 2d 63 6f 6e 6e 73 20 74 74 64 61 74 29 20 tt-conns ttdat)
1080: 64 62 66 6e 61 6d 65 20 63 6f 6e 6e 29 0a 3b 3b dbfname conn).;;
1090: 20 09 09 28 74 74 3a 68 61 6e 64 6c 65 72 20 20 ..(tt:handler
10a0: 74 74 64 61 74 20 63 6d 64 20 72 75 6e 2d 69 64 ttdat cmd run-id
10b0: 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e params attemptn
10c0: 75 6d 20 61 72 65 61 2d 64 61 74 20 61 72 65 61 um area-dat area
10d0: 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f path readonly-mo
10e0: 64 65 0a 3b 3b 20 09 09 09 20 20 20 20 20 64 62 de.;; ... db
10f0: 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 65 20 fname testsuite
1100: 6d 74 65 78 65 29 29 0a 3b 3b 20 09 20 20 20 20 mtexe)).;; .
1110: 20 20 3b 3b 20 6e 6f 20 73 65 72 76 65 72 2c 20 ;; no server,
1120: 74 72 79 20 74 6f 20 73 74 61 72 74 20 61 20 73 try to start a s
1130: 65 72 76 65 72 20 70 72 6f 63 65 73 73 0a 3b 3b erver process.;;
1140: 20 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b . (begin.;
1150: 3b 20 09 09 28 74 74 3a 73 65 72 76 65 72 2d 70 ; ..(tt:server-p
1160: 72 6f 63 65 73 73 2d 72 75 6e 20 61 72 65 61 70 rocess-run areap
1170: 61 74 68 20 74 65 73 74 73 75 69 74 65 20 6d 74 ath testsuite mt
1180: 65 78 65 20 72 75 6e 2d 69 64 29 20 3b 3b 20 20 exe run-id) ;;
1190: 23 21 6b 65 79 20 28 70 72 6f 66 69 6c 65 2d 6d #!key (profile-m
11a0: 6f 64 65 20 22 22 29 29 20 0a 3b 3b 20 09 09 28 ode "")) .;; ..(
11b0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
11c0: 0a 3b 3b 20 09 09 28 74 74 3a 68 61 6e 64 6c 65 .;; ..(tt:handle
11d0: 72 20 20 74 74 64 61 74 20 63 6d 64 20 72 75 6e r ttdat cmd run
11e0: 2d 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d -id params attem
11f0: 70 74 6e 75 6d 20 61 72 65 61 2d 64 61 74 20 61 ptnum area-dat a
1200: 72 65 61 70 61 74 68 0a 3b 3b 20 09 09 09 20 20 reapath.;; ...
1210: 20 20 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 readonly-mode
1220: 20 64 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 dbfname testsui
1230: 74 65 20 6d 74 65 78 65 29 29 29 29 29 29 29 0a te mtexe))))))).
1240: 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 62 69 64 .(define (tt:bid
1250: 2d 66 6f 72 2d 73 65 72 76 65 72 73 68 69 70 20 -for-servership
1260: 72 75 6e 2d 69 64 29 0a 20 20 23 66 29 0a 0a 28 run-id). #f)..(
1270: 64 65 66 69 6e 65 20 28 74 74 3a 67 65 74 2d 63 define (tt:get-c
1280: 75 72 72 65 6e 74 2d 73 65 72 76 65 72 2d 69 6e urrent-server-in
1290: 66 6f 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 fo ttdat dbfname
12a0: 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 2a run-id). (let*
12b0: 20 28 28 73 66 69 6c 65 73 20 28 74 74 3a 66 69 ((sfiles (tt:fi
12c0: 6e 64 2d 73 65 72 76 65 72 20 74 74 64 61 74 20 nd-server ttdat
12d0: 64 62 66 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 dbfname))). (
12e0: 63 61 73 65 20 28 6c 65 6e 67 74 68 20 73 66 69 case (length sfi
12f0: 6c 65 73 29 0a 20 20 20 20 20 20 28 28 30 29 20 les). ((0)
1300: 23 66 29 20 3b 3b 20 6e 6f 20 73 65 72 76 65 72 #f) ;; no server
1310: 20 61 72 6f 75 6e 64 0a 20 20 20 20 20 20 28 28 around. ((
1320: 31 29 20 28 74 74 3a 73 65 72 76 65 72 2d 67 65 1) (tt:server-ge
1330: 74 2d 69 6e 66 6f 20 28 63 61 72 20 73 66 69 6c t-info (car sfil
1340: 65 73 29 29 29 0a 20 20 20 20 20 20 28 65 6c 73 es))). (els
1350: 65 20 23 66 29 20 3b 3b 20 77 65 27 6c 6c 20 77 e #f) ;; we'll w
1360: 61 6e 74 20 74 6f 20 77 61 69 74 20 75 6e 74 69 ant to wait unti
1370: 6c 20 65 78 74 72 61 20 73 65 72 76 65 72 73 20 l extra servers
1380: 68 61 76 65 20 65 78 69 74 65 64 0a 20 20 20 20 have exited.
1390: 20 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))..(define (
13a0: 74 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 tt:send-receive
13b0: 74 74 64 61 74 20 63 6f 6e 6e 20 63 6d 64 20 72 ttdat conn cmd r
13c0: 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 0a 20 20 un-id params).
13d0: 28 6c 65 74 2a 20 28 28 68 6f 73 74 2d 70 6f 72 (let* ((host-por
13e0: 74 20 28 63 6f 6e 63 20 28 74 74 2d 63 6f 6e 6e t (conc (tt-conn
13f0: 2d 68 6f 73 74 20 63 6f 6e 6e 29 22 3a 22 28 74 -host conn)":"(t
1400: 74 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e t-conn-port conn
1410: 29 29 29 0a 09 20 28 64 61 74 20 20 20 20 20 20 ))).. (dat
1420: 20 28 6c 69 73 74 20 63 6d 64 20 72 75 6e 2d 69 (list cmd run-i
1430: 64 20 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 d params))).
1440: 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 69 (let-values (((i
1450: 6e 70 20 6f 75 70 29 28 74 63 70 2d 63 6f 6e 6e np oup)(tcp-conn
1460: 65 63 74 20 68 6f 73 74 2d 70 6f 72 74 29 29 29 ect host-port)))
1470: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
1480: 73 20 28 69 66 20 28 61 6e 64 20 69 6e 70 20 6f s (if (and inp o
1490: 75 70 29 0a 09 09 20 20 20 20 20 28 62 65 67 69 up)... (begi
14a0: 6e 0a 09 09 20 20 20 20 20 20 20 28 73 65 72 69 n... (seri
14b0: 61 6c 69 7a 65 20 64 61 74 20 6f 75 70 29 0a 09 alize dat oup)..
14c0: 09 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f . (close-o
14d0: 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a utput-port oup).
14e0: 09 09 20 20 20 20 20 20 20 28 64 65 73 65 72 69 .. (deseri
14f0: 61 6c 69 7a 65 20 69 6e 70 29 29 0a 09 09 20 20 alize inp))...
1500: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
1510: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1520: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1530: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 73 65 6e ort* "ERROR: sen
1540: 64 20 63 61 6c 6c 65 64 20 62 75 74 20 6e 6f 20 d called but no
1550: 72 65 63 65 69 76 65 72 20 68 61 73 20 62 65 65 receiver has bee
1560: 6e 20 73 65 74 75 70 2e 20 50 6c 65 61 73 65 20 n setup. Please
1570: 63 61 6c 6c 20 73 65 74 75 70 20 66 69 72 73 74 call setup first
1580: 21 22 29 0a 09 09 20 20 20 20 20 20 20 23 66 29 !")... #f)
1590: 29 29 29 0a 09 28 63 6c 6f 73 65 2d 69 6e 70 75 )))..(close-inpu
15a0: 74 2d 70 6f 72 74 20 69 6e 70 29 0a 09 3b 3b 20 t-port inp)..;;
15b0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
15c0: 73 65 6e 64 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 send-mutex*) ;;
15d0: 44 4f 45 53 4e 27 54 20 53 45 45 4d 20 54 4f 20 DOESN'T SEEM TO
15e0: 48 45 4c 50 0a 09 72 65 73 29 29 29 29 0a 0a 3b HELP..res))))..;
15f0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1630: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 73 65 72 76 65 =======.;; serve
1640: 72 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d r.;;============
1650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
1690: 69 6e 65 20 28 74 74 3a 73 79 6e 63 2d 64 62 73 ine (tt:sync-dbs
16a0: 20 74 74 64 61 74 29 0a 20 20 23 66 29 0a 0a 3b ttdat). #f)..;
16b0: 3b 20 73 74 61 72 74 20 74 68 65 20 6c 69 73 74 ; start the list
16c0: 65 6e 65 72 20 61 6e 64 20 73 74 61 72 74 20 72 ener and start r
16d0: 65 73 70 6f 6e 64 69 6e 67 20 74 6f 20 72 65 71 esponding to req
16e0: 75 65 73 74 73 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 uests.;;.;; NOTE
16f0: 3a 20 6f 72 67 61 6e 69 73 65 20 62 79 20 64 62 : organise by db
1700: 66 6e 61 6d 65 2c 20 6e 6f 74 20 72 75 6e 2d 69 fname, not run-i
1710: 64 20 73 6f 20 77 65 20 64 6f 6e 27 74 20 6e 65 d so we don't ne
1720: 65 64 0a 3b 3b 20 20 20 20 20 20 20 74 6f 20 70 ed.;; to p
1730: 75 6c 6c 20 69 6e 20 6d 6f 72 65 20 6d 6f 64 75 ull in more modu
1740: 6c 65 73 0a 3b 3b 0a 3b 3b 20 54 68 69 73 20 69 les.;;.;; This i
1750: 73 20 74 68 65 20 72 6f 75 74 69 6e 65 20 63 61 s the routine ca
1760: 6c 6c 65 64 20 69 6e 20 6d 65 67 61 74 65 73 74 lled in megatest
1770: 2e 73 63 6d 20 74 6f 20 73 74 61 72 74 20 61 20 .scm to start a
1780: 73 65 72 76 65 72 0a 3b 3b 0a 28 64 65 66 69 6e server.;;.(defin
1790: 65 20 28 74 74 3a 73 74 61 72 74 2d 73 65 72 76 e (tt:start-serv
17a0: 65 72 20 61 72 65 61 70 61 74 68 20 72 75 6e 2d er areapath run-
17b0: 69 64 20 64 62 66 6e 61 6d 65 20 68 61 6e 64 6c id dbfname handl
17c0: 65 72 29 0a 20 20 3b 3b 20 69 73 20 74 68 65 72 er). ;; is ther
17d0: 65 20 61 6c 72 65 61 64 79 20 61 20 73 65 72 76 e already a serv
17e0: 65 72 20 66 6f 72 20 74 68 69 73 20 64 62 66 69 er for this dbfi
17f0: 6c 65 3f 20 54 68 65 6e 20 65 78 69 74 2e 0a 20 le? Then exit..
1800: 20 28 6c 65 74 2a 20 28 28 74 74 64 61 74 20 20 (let* ((ttdat
1810: 20 28 6d 61 6b 65 2d 74 74 20 61 72 65 61 70 61 (make-tt areapa
1820: 74 68 3a 20 61 72 65 61 70 61 74 68 29 29 0a 09 th: areapath))..
1830: 20 28 73 65 72 76 65 72 73 20 28 74 74 3a 66 69 (servers (tt:fi
1840: 6e 64 2d 73 65 72 76 65 72 20 74 74 64 61 74 20 nd-server ttdat
1850: 64 62 66 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 dbfname))). (
1860: 74 74 2d 68 61 6e 64 6c 65 72 2d 73 65 74 21 20 tt-handler-set!
1870: 74 74 64 61 74 20 68 61 6e 64 6c 65 72 29 0a 20 ttdat handler).
1880: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 73 65 (if (null? se
1890: 72 76 65 72 73 29 0a 09 28 6c 65 74 2a 20 28 28 rvers)..(let* ((
18a0: 64 62 73 74 72 75 63 74 20 20 20 28 64 62 6d 6f dbstruct (dbmo
18b0: 64 3a 6f 70 65 6e 2d 64 62 6d 6f 64 64 62 20 61 d:open-dbmoddb a
18c0: 72 65 61 70 61 74 68 20 72 75 6e 2d 69 64 20 28 reapath run-id (
18d0: 64 62 66 69 6c 65 3a 64 62 2d 69 6e 69 74 2d 70 dbfile:db-init-p
18e0: 72 6f 63 29 29 29 0a 09 20 20 20 20 20 20 20 28 roc))).. (
18f0: 74 63 70 2d 74 68 72 65 61 64 20 28 6d 61 6b 65 tcp-thread (make
1900: 2d 74 68 72 65 61 64 0a 09 09 09 20 20 20 20 28 -thread.... (
1910: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
1920: 20 20 20 28 74 74 3a 73 74 61 72 74 2d 74 63 70 (tt:start-tcp
1930: 2d 73 65 72 76 65 72 20 74 74 64 61 74 29 29 20 -server ttdat))
1940: 3b 3b 20 73 74 61 72 74 20 74 68 65 20 74 63 70 ;; start the tcp
1950: 2d 73 65 72 76 65 72 20 77 68 69 63 68 20 61 70 -server which ap
1960: 70 6c 69 65 73 20 68 61 6e 64 6c 65 72 20 74 6f plies handler to
1970: 20 69 6e 63 6f 6d 69 6e 67 20 64 61 74 61 0a 09 incoming data..
1980: 09 09 20 20 20 20 22 74 63 70 2d 73 65 72 76 65 .. "tcp-serve
1990: 72 2d 74 68 72 65 61 64 22 29 29 0a 09 20 20 20 r-thread"))..
19a0: 20 20 20 20 28 72 75 6e 2d 74 68 72 65 61 64 20 (run-thread
19b0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 (make-thread....
19c0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
19d0: 09 09 20 20 20 20 20 20 28 74 74 3a 6b 65 65 70 .. (tt:keep
19e0: 2d 72 75 6e 6e 69 6e 67 20 74 74 64 61 74 20 64 -running ttdat d
19f0: 62 66 6e 61 6d 65 29 29 29 29 29 0a 09 20 20 28 bfname))))).. (
1a00: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 63 thread-start! tc
1a10: 70 2d 74 68 72 65 61 64 29 0a 09 20 20 28 74 68 p-thread).. (th
1a20: 72 65 61 64 2d 73 74 61 72 74 21 20 72 75 6e 2d read-start! run-
1a30: 74 68 72 65 61 64 29 0a 09 20 20 28 74 68 72 65 thread).. (thre
1a40: 61 64 2d 6a 6f 69 6e 21 20 72 75 6e 2d 74 68 72 ad-join! run-thr
1a50: 65 61 64 29 20 3b 3b 20 72 75 6e 20 74 68 72 65 ead) ;; run thre
1a60: 61 64 20 77 69 6c 6c 20 65 78 69 74 20 6f 6e 20 ad will exit on
1a70: 74 69 6d 65 6f 75 74 20 6f 72 20 6f 74 68 65 72 timeout or other
1a80: 20 63 6f 6e 64 69 74 69 6f 6e 73 0a 09 20 20 3b conditions.. ;
1a90: 3b 0a 09 20 20 3b 3b 20 73 65 74 20 61 20 66 6c ;.. ;; set a fl
1aa0: 61 67 20 68 65 72 65 20 74 6f 20 74 65 6c 6c 20 ag here to tell
1ab0: 74 63 70 2d 74 68 72 65 61 64 20 74 6f 20 73 74 tcp-thread to st
1ac0: 6f 70 20 72 75 6e 6e 69 6e 67 0a 09 20 20 3b 3b op running.. ;;
1ad0: 0a 09 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 6a .. ;; (thread-j
1ae0: 6f 69 6e 21 20 74 63 70 2d 74 68 72 65 61 64 29 oin! tcp-thread)
1af0: 20 3b 3b 20 63 61 6e 27 74 20 77 61 69 74 20 0a ;; can't wait .
1b00: 09 20 20 3b 3b 0a 09 20 20 3b 3b 20 72 65 6d 6f . ;;.. ;; remo
1b10: 76 65 20 74 68 65 20 73 65 72 76 69 6e 66 6f 20 ve the servinfo
1b20: 66 69 6c 65 0a 09 20 20 3b 3b 0a 09 20 20 3b 3b file.. ;;.. ;;
1b30: 20 63 6c 6f 73 65 20 74 68 65 20 64 61 74 61 62 close the datab
1b40: 61 73 65 2c 20 72 65 6d 6f 76 65 20 6c 6f 63 6b ase, remove lock
1b50: 20 69 6e 20 6f 6e 2d 64 69 73 6b 20 64 62 0a 09 in on-disk db..
1b60: 20 20 3b 3b 0a 09 20 20 3b 3b 20 63 6c 6f 73 65 ;;.. ;; close
1b70: 20 74 68 65 20 6c 69 73 74 65 6e 65 72 20 70 6f the listener po
1b80: 72 74 73 0a 09 20 20 3b 3b 0a 09 20 20 28 65 78 rts.. ;;.. (ex
1b90: 69 74 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 it))..(begin..
1ba0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1bb0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1bc0: 2a 20 22 49 4e 46 4f 3a 20 66 6f 75 6e 64 20 73 * "INFO: found s
1bd0: 65 72 76 65 72 28 73 29 20 61 6c 72 65 61 64 79 erver(s) already
1be0: 20 72 75 6e 6e 69 6e 67 20 66 6f 72 20 64 62 20 running for db
1bf0: 22 64 62 66 6e 61 6d 65 22 2c 20 22 28 73 74 72 "dbfname", "(str
1c00: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
1c10: 73 65 72 76 65 72 73 20 22 2c 22 29 22 20 45 78 servers ",")" Ex
1c20: 69 74 69 6e 67 2e 22 29 0a 09 20 20 28 65 78 69 iting.").. (exi
1c30: 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 t)))))..(define
1c40: 28 74 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 (tt:keep-running
1c50: 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 0a ttdat dbfname).
1c60: 20 20 3b 3b 20 76 65 72 66 69 79 20 63 6f 6e 6e ;; verfiy conn
1c70: 20 66 6f 72 20 72 65 61 64 79 0a 20 20 3b 3b 20 for ready. ;;
1c80: 6c 69 73 74 65 6e 65 72 20 73 6f 63 6b 65 74 20 listener socket
1c90: 68 61 73 20 62 65 65 6e 20 73 74 61 72 74 65 64 has been started
1ca0: 20 62 79 20 74 68 69 73 20 73 74 61 67 65 0a 20 by this stage.
1cb0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
1cc0: 31 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 1). (let loop (
1cd0: 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 28 (count 0)). (
1ce0: 69 66 20 28 3e 20 63 6f 75 6e 74 20 36 30 29 0a if (> count 60).
1cf0: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
1d00: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
1d10: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 41 lt-log-port* "FA
1d20: 54 41 4c 3a 20 43 6f 75 6c 64 20 6e 6f 74 20 73 TAL: Could not s
1d30: 74 61 72 74 20 61 20 74 63 70 20 73 65 72 76 65 tart a tcp serve
1d40: 72 2c 20 67 69 76 69 6e 67 20 75 70 2e 22 29 0a r, giving up.").
1d50: 09 20 20 28 65 78 69 74 20 31 29 29 0a 09 28 69 . (exit 1))..(i
1d60: 66 20 28 6e 6f 74 20 28 74 74 2d 70 6f 72 74 20 f (not (tt-port
1d70: 74 74 64 61 74 29 29 20 3b 3b 20 6e 6f 20 63 6f ttdat)) ;; no co
1d80: 6e 6e 65 63 74 69 6f 6e 20 79 65 74 0a 09 20 20 nnection yet..
1d90: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
1da0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
1db0: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ).. (loop (
1dc0: 2b 20 63 6f 75 6e 74 20 31 29 29 29 29 29 29 0a + count 1)))))).
1dd0: 20 20 0a 20 20 28 74 74 3a 63 72 65 61 74 65 2d . (tt:create-
1de0: 73 65 72 76 65 72 2d 72 65 67 69 73 74 72 61 74 server-registrat
1df0: 69 6f 6e 2d 66 69 6c 65 20 74 74 64 61 74 20 64 ion-file ttdat d
1e00: 62 66 6e 61 6d 65 29 0a 20 20 3b 3b 20 6e 6f 77 bfname). ;; now
1e10: 20 73 74 61 72 74 20 77 61 74 63 68 69 6e 67 20 start watching
1e20: 74 68 65 20 6c 61 73 74 2d 61 63 63 65 73 73 2c the last-access,
1e30: 20 69 66 20 69 74 20 68 61 73 6e 27 74 20 62 65 if it hasn't be
1e40: 65 6e 20 74 6f 75 63 68 65 64 0a 20 20 3b 3b 20 en touched. ;;
1e50: 69 6e 20 6f 76 65 72 20 74 65 6e 20 73 65 63 6f in over ten seco
1e60: 6e 64 73 20 77 65 20 65 78 69 74 0a 20 20 28 6c nds we exit. (l
1e70: 65 74 20 6c 6f 6f 70 20 28 29 0a 20 20 20 20 28 et loop (). (
1e80: 69 66 20 28 3c 20 28 2d 20 28 63 75 72 72 65 6e if (< (- (curren
1e90: 74 2d 73 65 63 6f 6e 64 73 29 20 28 74 74 2d 6c t-seconds) (tt-l
1ea0: 61 73 74 2d 61 63 63 65 73 73 20 74 74 64 61 74 ast-access ttdat
1eb0: 29 29 20 31 30 29 0a 09 28 62 65 67 69 6e 0a 09 )) 10)..(begin..
1ec0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
1ed0: 20 32 29 0a 09 20 20 28 6c 6f 6f 70 29 29 29 29 2).. (loop))))
1ee0: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
1ef0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1f00: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 53 65 72 76 ort* "INFO: Serv
1f10: 65 72 20 74 69 6d 65 64 20 6f 75 74 2c 20 65 78 er timed out, ex
1f20: 69 74 69 6e 67 2e 22 29 29 0a 0a 3b 3b 20 3b 3b iting."))..;; ;;
1f30: 20 67 69 76 65 6e 20 61 6e 20 61 6c 72 65 61 64 given an alread
1f40: 79 20 73 65 74 20 75 70 20 75 63 6f 6e 6e 20 73 y set up uconn s
1f50: 74 61 72 74 20 74 68 65 20 63 6d 64 2d 6c 6f 6f tart the cmd-loo
1f60: 70 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 p.;; ;;.;; (defi
1f70: 6e 65 20 28 74 74 3a 63 6d 64 2d 6c 6f 6f 70 20 ne (tt:cmd-loop
1f80: 74 74 64 61 74 29 0a 3b 3b 20 20 20 28 6c 65 74 ttdat).;; (let
1f90: 2a 20 28 28 73 65 72 76 2d 6c 69 73 74 65 6e 65 * ((serv-listene
1fa0: 72 20 28 2d 73 6f 63 6b 65 74 20 75 63 6f 6e 6e r (-socket uconn
1fb0: 29 29 0a 3b 3b 20 09 20 28 6c 69 73 74 65 6e 65 )).;; . (listene
1fc0: 72 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 r (lambda (
1fd0: 29 0a 3b 3b 20 09 09 09 20 20 28 6c 65 74 20 6c ).;; ... (let l
1fe0: 6f 6f 70 20 28 28 73 74 61 74 65 20 27 73 74 61 oop ((state 'sta
1ff0: 72 74 29 29 0a 3b 3b 20 09 09 09 20 20 20 20 28 rt)).;; ... (
2000: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e let-values (((in
2010: 70 20 6f 75 70 29 28 74 63 70 2d 61 63 63 65 70 p oup)(tcp-accep
2020: 74 20 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 29 t serv-listener)
2030: 29 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 3b )).;; ... ;
2040: 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a ; (mutex-lock! *
2050: 73 65 6e 64 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 send-mutex*) ;;
2060: 44 4f 45 53 4e 27 54 20 53 45 45 4d 20 54 4f 20 DOESN'T SEEM TO
2070: 48 45 4c 50 0a 3b 3b 20 09 09 09 20 20 20 20 20 HELP.;; ...
2080: 20 28 6c 65 74 2a 20 28 28 72 64 61 74 20 20 28 (let* ((rdat (
2090: 64 65 73 65 72 69 61 6c 69 7a 65 20 69 6e 70 29 deserialize inp)
20a0: 29 20 3b 3b 20 27 28 6d 79 2d 68 6f 73 74 2d 70 ) ;; '(my-host-p
20b0: 6f 72 74 20 71 72 79 6b 65 79 20 63 6d 64 20 70 ort qrykey cmd p
20c0: 61 72 61 6d 73 29 0a 3b 3b 20 09 09 09 09 20 20 arams).;; ....
20d0: 20 20 20 28 72 65 73 70 20 20 28 75 6c 65 78 2d (resp (ulex-
20e0: 68 61 6e 64 6c 65 72 20 75 63 6f 6e 6e 20 72 64 handler uconn rd
20f0: 61 74 29 29 29 0a 3b 3b 20 09 09 09 09 28 73 65 at))).;; ....(se
2100: 72 69 61 6c 69 7a 65 20 72 65 73 70 20 6f 75 70 rialize resp oup
2110: 29 0a 3b 3b 20 09 09 09 09 28 63 6c 6f 73 65 2d ).;; ....(close-
2120: 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a input-port inp).
2130: 3b 3b 20 09 09 09 09 28 63 6c 6f 73 65 2d 6f 75 ;; ....(close-ou
2140: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 3b tput-port oup).;
2150: 3b 20 09 09 09 09 3b 3b 20 28 6d 75 74 65 78 2d ; ....;; (mutex-
2160: 75 6e 6c 6f 63 6b 21 20 2a 73 65 6e 64 2d 6d 75 unlock! *send-mu
2170: 74 65 78 2a 29 20 3b 3b 20 44 4f 45 53 4e 27 54 tex*) ;; DOESN'T
2180: 20 53 45 45 4d 20 54 4f 20 48 45 4c 50 0a 3b 3b SEEM TO HELP.;;
2190: 20 09 09 09 09 29 0a 3b 3b 20 09 09 09 20 20 20 ....).;; ...
21a0: 20 20 20 28 6c 6f 6f 70 20 73 74 61 74 65 29 29 (loop state))
21b0: 29 29 29 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 73 )))).;; ;; s
21c0: 74 61 72 74 20 4e 20 6f 66 20 74 68 65 6d 0a 3b tart N of them.;
21d0: 3b 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ; (let loop
21e0: 28 28 74 68 6e 75 6d 20 20 20 30 29 0a 3b 3b 20 ((thnum 0).;;
21f0: 09 20 20 20 20 20 20 20 28 74 68 72 65 61 64 73 . (threads
2200: 20 27 28 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 '())).;;
2210: 28 69 66 20 28 3c 20 74 68 6e 75 6d 20 31 30 30 (if (< thnum 100
2220: 29 0a 3b 3b 20 09 20 20 28 6c 65 74 2a 20 28 28 ).;; . (let* ((
2230: 74 68 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 th (make-thread
2240: 6c 69 73 74 65 6e 65 72 20 28 63 6f 6e 63 20 22 listener (conc "
2250: 6c 69 73 74 65 6e 65 72 22 20 74 68 6e 75 6d 29 listener" thnum)
2260: 29 29 29 0a 3b 3b 20 09 20 20 20 20 28 74 68 72 ))).;; . (thr
2270: 65 61 64 2d 73 74 61 72 74 21 20 74 68 29 0a 3b ead-start! th).;
2280: 3b 20 09 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 ; . (loop (+
2290: 74 68 6e 75 6d 20 31 29 0a 3b 3b 20 09 09 20 20 thnum 1).;; ..
22a0: 28 63 6f 6e 73 20 74 68 20 74 68 72 65 61 64 73 (cons th threads
22b0: 29 29 29 0a 3b 3b 20 09 20 20 28 6d 61 70 20 74 ))).;; . (map t
22c0: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 72 65 hread-join! thre
22d0: 61 64 73 29 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 ads))))).;; .;;
22e0: 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 .;; .;; (define
22f0: 28 77 61 69 74 2d 61 6e 64 2d 63 6c 6f 73 65 20 (wait-and-close
2300: 75 63 6f 6e 6e 29 0a 3b 3b 20 20 20 28 74 68 72 uconn).;; (thr
2310: 65 61 64 2d 6a 6f 69 6e 21 20 28 75 64 61 74 2d ead-join! (udat-
2320: 63 6d 64 2d 74 68 72 65 61 64 20 75 63 6f 6e 6e cmd-thread uconn
2330: 29 29 0a 3b 3b 20 20 20 28 74 63 70 2d 63 6c 6f )).;; (tcp-clo
2340: 73 65 20 28 75 64 61 74 2d 73 6f 63 6b 65 74 20 se (udat-socket
2350: 75 63 6f 6e 6e 29 29 29 0a 3b 3b 20 0a 3b 3b 20 uconn))).;; .;;
2360: 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 73 68 ..(define (tt:sh
2370: 75 74 64 6f 77 6e 2d 73 65 72 76 65 72 20 74 74 utdown-server tt
2380: 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 dat). (let* ((c
2390: 6c 65 61 6e 70 72 6f 63 20 28 74 74 2d 63 6c 65 leanproc (tt-cle
23a0: 61 6e 75 70 2d 70 72 6f 63 20 74 74 64 61 74 29 anup-proc ttdat)
23b0: 29 29 0a 20 20 20 20 28 69 66 20 63 6c 65 61 6e )). (if clean
23c0: 70 72 6f 63 20 28 63 6c 65 61 6e 70 72 6f 63 29 proc (cleanproc)
23d0: 29 0a 20 20 20 20 28 74 63 70 2d 63 6c 6f 73 65 ). (tcp-close
23e0: 20 28 74 74 2d 73 6f 63 6b 65 74 20 74 74 64 61 (tt-socket ttda
23f0: 74 29 29 20 3b 3b 20 63 6c 6f 73 65 20 75 70 20 t)) ;; close up
2400: 70 6f 72 74 73 20 68 65 72 65 0a 20 20 20 20 29 ports here. )
2410: 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 77 )..;; (define (w
2420: 61 69 74 2d 61 6e 64 2d 63 6c 6f 73 65 20 75 63 ait-and-close uc
2430: 6f 6e 6e 29 0a 3b 3b 20 20 20 28 74 68 72 65 61 onn).;; (threa
2440: 64 2d 6a 6f 69 6e 21 20 28 74 74 2d 63 6d 64 2d d-join! (tt-cmd-
2450: 74 68 72 65 61 64 20 75 63 6f 6e 6e 29 29 0a 3b thread uconn)).;
2460: 3b 20 20 20 28 74 63 70 2d 63 6c 6f 73 65 20 28 ; (tcp-close (
2470: 74 74 2d 73 6f 63 6b 65 74 20 75 63 6f 6e 6e 29 tt-socket uconn)
2480: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 73 65 ))..;; return se
2490: 72 76 69 64 0a 3b 3b 20 73 69 64 65 2d 65 66 66 rvid.;; side-eff
24a0: 65 63 74 73 3a 0a 3b 3b 20 20 20 74 74 64 61 74 ects:.;; ttdat
24b0: 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 20 69 73 -cleanup-proc is
24c0: 20 70 6f 70 75 6c 61 74 65 64 20 77 69 74 68 20 populated with
24d0: 66 75 6e 63 74 69 6f 6e 20 74 6f 20 72 65 6d 6f function to remo
24e0: 76 65 20 74 68 65 20 73 65 72 76 65 72 69 6e 66 ve the serverinf
24f0: 6f 20 66 69 6c 65 0a 28 64 65 66 69 6e 65 20 28 o file.(define (
2500: 74 74 3a 63 72 65 61 74 65 2d 73 65 72 76 65 72 tt:create-server
2510: 2d 72 65 67 69 73 74 72 61 74 69 6f 6e 2d 66 69 -registration-fi
2520: 6c 65 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 le ttdat dbfname
2530: 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 72 65 61 ). (let* ((area
2540: 70 61 74 68 20 28 74 74 2d 61 72 65 61 70 61 74 path (tt-areapat
2550: 68 20 74 74 64 61 74 29 29 0a 09 20 28 73 65 72 h ttdat)).. (ser
2560: 76 64 69 72 20 20 28 74 74 3a 67 65 74 2d 73 65 vdir (tt:get-se
2570: 72 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 rvinfo-dir areap
2580: 61 74 68 29 29 0a 09 20 28 68 6f 73 74 20 20 20 ath)).. (host
2590: 20 20 28 74 74 2d 68 6f 73 74 20 74 74 64 61 74 (tt-host ttdat
25a0: 29 29 0a 09 20 28 70 6f 72 74 20 20 20 20 20 28 )).. (port (
25b0: 74 74 2d 70 6f 72 74 20 74 74 64 61 74 29 29 0a tt-port ttdat)).
25c0: 09 20 28 73 65 72 76 69 6e 66 20 28 63 6f 6e 63 . (servinf (conc
25d0: 20 73 65 72 76 64 69 72 22 2f 22 68 6f 73 74 22 servdir"/"host"
25e0: 3a 22 70 6f 72 74 22 2d 22 28 63 75 72 72 65 6e :"port"-"(curren
25f0: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 3a 22 t-process-id)":"
2600: 64 62 66 6e 61 6d 65 29 29 0a 09 20 28 73 65 72 dbfname)).. (ser
2610: 76 2d 69 64 20 28 74 74 3a 6d 6b 2d 73 69 67 6e v-id (tt:mk-sign
2620: 61 74 75 72 65 20 61 72 65 61 70 61 74 68 29 29 ature areapath))
2630: 0a 09 20 28 63 6c 65 61 6e 2d 70 72 6f 63 20 28 .. (clean-proc (
2640: 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 lambda ()...
2650: 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a (delete-file*
2660: 20 73 65 72 76 69 6e 66 29 29 29 29 0a 20 20 20 servinf)))).
2670: 20 28 61 73 73 65 72 74 20 28 61 6e 64 20 68 6f (assert (and ho
2680: 73 74 20 70 6f 72 74 29 20 22 46 41 54 41 4c 3a st port) "FATAL:
2690: 20 74 74 3a 63 72 65 61 74 65 2d 73 65 72 76 65 tt:create-serve
26a0: 72 2d 72 65 67 69 73 74 72 61 74 69 6f 6e 2d 66 r-registration-f
26b0: 69 6c 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 ile called with
26c0: 6e 6f 20 63 6f 6e 6e 2c 20 64 62 66 6e 61 6d 65 no conn, dbfname
26d0: 3d 22 64 62 66 6e 61 6d 65 29 0a 20 20 20 20 28 ="dbfname). (
26e0: 74 74 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 2d tt-cleanup-proc-
26f0: 73 65 74 21 20 74 74 64 61 74 20 63 6c 65 61 6e set! ttdat clean
2700: 2d 70 72 6f 63 29 0a 20 20 20 20 28 77 69 74 68 -proc). (with
2710: 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 -output-to-file
2720: 73 65 72 76 69 6e 66 0a 20 20 20 20 20 20 28 6c servinf. (l
2730: 61 6d 62 64 61 20 28 29 0a 09 28 70 72 69 6e 74 ambda ()..(print
2740: 20 22 53 45 52 56 45 52 20 53 54 41 52 54 45 44 "SERVER STARTED
2750: 3a 20 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 20 : "host":"port"
2760: 41 54 20 22 28 63 75 72 72 65 6e 74 2d 73 65 63 AT "(current-sec
2770: 6f 6e 64 73 29 22 20 73 65 72 76 65 72 2d 69 64 onds)" server-id
2780: 3a 20 22 73 65 72 76 2d 69 64 22 20 70 69 64 3a : "serv-id" pid:
2790: 20 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 "(current-proce
27a0: 73 73 2d 69 64 29 22 20 64 62 66 6e 61 6d 65 3a ss-id)" dbfname:
27b0: 20 22 64 62 66 6e 61 6d 65 29 29 29 0a 20 20 20 "dbfname))).
27c0: 20 20 20 73 65 72 76 2d 69 64 29 29 0a 0a 3b 3b serv-id))..;;
27d0: 20 66 69 6e 64 20 76 61 6c 69 64 20 73 65 72 76 find valid serv
27e0: 65 72 0a 3b 3b 20 67 65 74 20 73 65 72 76 65 72 er.;; get server
27f0: 73 20 6c 69 73 74 65 64 2c 20 6c 61 73 74 20 70 s listed, last p
2800: 61 72 74 20 6f 66 20 6e 61 6d 65 20 6d 75 73 74 art of name must
2810: 20 6d 61 74 63 68 20 3a 3c 64 62 66 6e 61 6d 65 match :<dbfname
2820: 3e 0a 3b 3b 20 69 66 20 6d 6f 72 65 20 74 68 61 >.;; if more tha
2830: 6e 20 6f 6e 65 2c 20 77 61 69 74 20 6f 6e 65 20 n one, wait one
2840: 73 65 63 6f 6e 64 20 61 6e 64 20 6c 6f 6f 6b 20 second and look
2850: 61 67 61 69 6e 0a 3b 3b 20 66 75 74 75 72 65 3a again.;; future:
2860: 20 70 69 6e 67 20 6f 6c 64 65 73 74 2c 20 69 66 ping oldest, if
2870: 20 61 6c 69 76 65 20 72 65 6d 6f 76 65 20 6f 74 alive remove ot
2880: 68 65 72 20 3a 3c 64 62 66 6e 61 6d 65 3e 20 66 her :<dbfname> f
2890: 69 6c 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 iles.;;.(define
28a0: 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 72 20 (tt:find-server
28b0: 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 0a 20 ttdat dbfname).
28c0: 20 28 6c 65 74 2a 20 28 28 61 72 65 61 70 61 74 (let* ((areapat
28d0: 68 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 74 h (tt-areapath t
28e0: 74 64 61 74 29 29 0a 09 20 28 73 65 72 76 64 69 tdat)).. (servdi
28f0: 72 20 20 28 74 74 3a 67 65 74 2d 73 65 72 76 69 r (tt:get-servi
2900: 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 61 74 68 nfo-dir areapath
2910: 29 29 0a 09 20 28 73 66 69 6c 65 73 20 20 20 28 )).. (sfiles (
2920: 67 6c 6f 62 20 28 63 6f 6e 63 20 73 65 72 76 64 glob (conc servd
2930: 69 72 22 2f 2a 3a 22 64 62 66 6e 61 6d 65 29 29 ir"/*:"dbfname))
2940: 29 29 0a 20 20 20 20 73 66 69 6c 65 73 29 29 0a )). sfiles)).
2950: 0a 3b 3b 20 67 69 76 65 6e 20 61 20 70 61 74 68 .;; given a path
2960: 20 74 6f 20 61 20 73 65 72 76 65 72 20 69 6e 66 to a server inf
2970: 6f 20 66 69 6c 65 20 72 65 74 75 72 6e 3a 20 68 o file return: h
2980: 6f 73 74 20 70 6f 72 74 20 73 74 61 72 74 73 65 ost port startse
2990: 63 6f 6e 64 73 20 73 65 72 76 65 72 2d 69 64 0a conds server-id.
29a0: 3b 3b 20 65 78 61 6d 70 6c 65 20 6f 66 20 77 68 ;; example of wh
29b0: 61 74 20 69 74 27 73 20 6c 6f 6f 6b 69 6e 67 20 at it's looking
29c0: 66 6f 72 20 69 6e 20 74 68 65 20 6c 6f 67 20 66 for in the log f
29d0: 69 6c 65 3a 0a 3b 3b 20 20 20 20 20 53 45 52 56 ile:.;; SERV
29e0: 45 52 20 53 54 41 52 54 45 44 3a 20 31 30 2e 33 ER STARTED: 10.3
29f0: 38 2e 31 37 35 2e 36 37 3a 35 30 32 31 36 20 41 8.175.67:50216 A
2a00: 54 20 31 36 31 36 35 30 32 33 35 30 2e 30 20 73 T 1616502350.0 s
2a10: 65 72 76 65 72 2d 69 64 3a 20 34 39 30 37 65 39 erver-id: 4907e9
2a20: 30 66 63 35 35 63 37 61 30 39 36 39 34 65 33 66 0fc55c7a09694e3f
2a30: 36 35 38 63 36 33 39 63 66 34 20 0a 3b 3b 0a 28 658c639cf4 .;;.(
2a40: 64 65 66 69 6e 65 20 28 74 74 3a 73 65 72 76 65 define (tt:serve
2a50: 72 2d 67 65 74 2d 69 6e 66 6f 20 6c 6f 67 66 29 r-get-info logf)
2a60: 0a 20 20 28 6c 65 74 20 28 28 73 65 72 76 65 72 . (let ((server
2a70: 2d 72 78 20 20 20 20 28 72 65 67 65 78 70 20 22 -rx (regexp "
2a80: 5e 53 45 52 56 45 52 20 53 54 41 52 54 45 44 3a ^SERVER STARTED:
2a90: 20 28 5c 5c 53 2b 29 3a 28 5c 5c 64 2b 29 20 41 (\\S+):(\\d+) A
2aa0: 54 20 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 20 73 65 T ([\\d\\.]+) se
2ab0: 72 76 65 72 2d 69 64 3a 20 28 5c 5c 53 2b 29 20 rver-id: (\\S+)
2ac0: 70 69 64 3a 20 28 5c 5c 64 2b 29 22 29 29 20 3b pid: (\\d+)")) ;
2ad0: 3b 20 53 45 52 56 45 52 20 53 54 41 52 54 45 44 ; SERVER STARTED
2ae0: 3a 20 68 6f 73 74 3a 70 6f 72 74 20 41 54 20 74 : host:port AT t
2af0: 69 6d 65 73 65 63 73 20 73 65 72 76 65 72 20 69 imesecs server i
2b00: 64 0a 20 20 20 20 20 20 20 20 28 64 62 70 72 65 d. (dbpre
2b10: 70 2d 72 78 20 20 20 20 28 72 65 67 65 78 70 20 p-rx (regexp
2b20: 22 5e 53 45 52 56 45 52 3a 20 64 62 70 72 65 70 "^SERVER: dbprep
2b30: 22 29 29 0a 20 20 20 20 20 20 20 20 28 64 62 70 ")). (dbp
2b40: 72 65 70 2d 66 6f 75 6e 64 20 30 29 0a 09 28 62 rep-found 0)..(b
2b50: 61 64 2d 64 61 74 20 20 20 20 20 20 28 6c 69 73 ad-dat (lis
2b60: 74 20 23 66 20 23 66 20 23 66 20 23 66 20 23 66 t #f #f #f #f #f
2b70: 29 29 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d ))). (handle-
2b80: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
2b90: 65 78 6e 0a 20 20 20 20 20 28 62 65 67 69 6e 0a exn. (begin.
2ba0: 20 20 20 20 20 20 20 3b 3b 20 57 41 52 4e 49 4e ;; WARNIN
2bb0: 47 3a 20 74 68 69 73 20 69 73 20 70 6f 74 65 6e G: this is poten
2bc0: 74 69 61 6c 6c 79 20 64 61 6e 67 65 72 6f 75 73 tially dangerous
2bd0: 20 74 6f 20 62 6c 61 6e 6b 65 74 20 69 67 6e 6f to blanket igno
2be0: 72 65 20 74 68 65 20 65 72 72 6f 72 73 0a 20 20 re the errors.
2bf0: 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 (if (file-e
2c00: 78 69 73 74 73 3f 20 6c 6f 67 66 29 0a 09 20 20 xists? logf)..
2c10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2c20: 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 2 *default-lo
2c30: 67 2d 70 6f 72 74 2a 20 22 55 6e 61 62 6c 65 20 g-port* "Unable
2c40: 74 6f 20 67 65 74 20 73 65 72 76 65 72 20 69 6e to get server in
2c50: 66 6f 20 66 72 6f 6d 20 22 6c 6f 67 66 22 2c 20 fo from "logf",
2c60: 65 78 6e 3d 22 20 65 78 6e 29 29 0a 20 20 20 20 exn=" exn)).
2c70: 20 20 20 62 61 64 2d 64 61 74 29 20 3b 3b 20 6e bad-dat) ;; n
2c80: 6f 20 69 64 65 61 20 77 68 61 74 20 77 65 6e 74 o idea what went
2c90: 20 77 72 6f 6e 67 2c 20 63 61 6c 6c 20 69 74 20 wrong, call it
2ca0: 61 20 62 61 64 20 73 65 72 76 65 72 0a 20 20 20 a bad server.
2cb0: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
2cc0: 6f 6d 2d 66 69 6c 65 0a 09 20 6c 6f 67 66 0a 20 om-file.. logf.
2cd0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
2ce0: 0a 09 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 .. (let loop ((i
2cf0: 6e 6c 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 nl (read-line))
2d00: 0a 09 09 20 20 20 20 28 6c 6e 75 6d 20 30 29 29 ... (lnum 0))
2d10: 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 .. (if (not (e
2d20: 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 29 of-object? inl))
2d30: 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
2d40: 6d 6c 73 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 mlst (string-mat
2d50: 63 68 20 73 65 72 76 65 72 2d 72 78 20 69 6e 6c ch server-rx inl
2d60: 29 29 0a 09 09 20 20 20 20 20 28 64 62 70 72 65 ))... (dbpre
2d70: 70 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 p (string-match
2d80: 64 62 70 72 65 70 2d 72 78 20 69 6e 6c 29 29 29 dbprep-rx inl)))
2d90: 0a 09 09 20 28 69 66 20 64 62 70 72 65 70 20 28 ... (if dbprep (
2da0: 73 65 74 21 20 64 62 70 72 65 70 2d 66 6f 75 6e set! dbprep-foun
2db0: 64 20 31 29 29 0a 09 09 20 28 69 66 20 28 6e 6f d 1))... (if (no
2dc0: 74 20 6d 6c 73 74 29 0a 09 09 20 20 20 20 20 28 t mlst)... (
2dd0: 69 66 20 28 3c 20 6c 6e 75 6d 20 35 30 30 29 20 if (< lnum 500)
2de0: 3b 3b 20 67 69 76 65 20 75 70 20 69 66 20 6d 6f ;; give up if mo
2df0: 72 65 20 74 68 61 6e 20 35 30 30 20 6c 69 6e 65 re than 500 line
2e00: 73 20 6f 66 20 73 65 72 76 65 72 20 6c 6f 67 20 s of server log
2e10: 72 65 61 64 0a 09 09 09 20 28 6c 6f 6f 70 20 28 read.... (loop (
2e20: 72 65 61 64 2d 6c 69 6e 65 29 28 2b 20 6c 6e 75 read-line)(+ lnu
2e30: 6d 20 31 29 29 0a 09 09 09 20 28 62 65 67 69 6e m 1)).... (begin
2e40: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
2e60: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
2e70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2e80: 72 74 2a 20 22 55 6e 61 62 6c 65 20 74 6f 20 67 rt* "Unable to g
2e90: 65 74 20 73 65 72 76 65 72 20 69 6e 66 6f 20 66 et server info f
2ea0: 72 6f 6d 20 66 69 72 73 74 20 35 30 30 20 6c 69 rom first 500 li
2eb0: 6e 65 73 20 6f 66 20 22 20 6c 6f 67 66 20 29 0a nes of " logf ).
2ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ed0: 20 20 20 20 20 20 20 20 20 20 20 62 61 64 2d 64 bad-d
2ee0: 61 74 29 29 0a 09 09 20 20 20 20 20 28 6d 61 74 at))... (mat
2ef0: 63 68 20 6d 6c 73 74 0a 09 09 09 20 20 20 20 28 ch mlst.... (
2f00: 28 5f 20 68 6f 73 74 20 70 6f 72 74 20 73 74 61 (_ host port sta
2f10: 72 74 20 73 65 72 76 65 72 2d 69 64 20 70 69 64 rt server-id pid
2f20: 29 0a 09 09 09 20 20 20 20 20 28 6c 69 73 74 20 ).... (list
2f30: 68 6f 73 74 0a 09 09 09 09 20 20 20 28 73 74 72 host..... (str
2f40: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 6f 72 74 ing->number port
2f50: 29 0a 09 09 09 09 20 20 20 28 73 74 72 69 6e 67 )..... (string
2f60: 2d 3e 6e 75 6d 62 65 72 20 73 74 61 72 74 29 0a ->number start).
2f70: 09 09 09 09 20 20 20 73 65 72 76 65 72 2d 69 64 .... server-id
2f80: 0a 09 09 09 09 20 20 20 28 73 74 72 69 6e 67 2d ..... (string-
2f90: 3e 6e 75 6d 62 65 72 20 70 69 64 29 29 29 0a 09 >number pid)))..
2fa0: 09 09 20 20 20 20 28 65 6c 73 65 0a 09 09 09 20 .. (else....
2fb0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2fc0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2fd0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 64 69 port* "ERROR: di
2fe0: 64 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 20 d not recognise
2ff0: 53 45 52 56 45 52 20 6c 69 6e 65 20 69 6e 66 6f SERVER line info
3000: 20 22 6d 6c 73 74 29 0a 09 09 09 20 20 20 20 20 "mlst)....
3010: 62 61 64 2d 64 61 74 29 29 29 29 0a 09 20 20 20 bad-dat))))..
3020: 20 20 20 20 28 62 65 67 69 6e 20 0a 09 09 20 28 (begin ... (
3030: 69 66 20 64 62 70 72 65 70 2d 66 6f 75 6e 64 0a if dbprep-found.
3040: 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 .. (begin...
3050: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
3060: 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 int-info 2 *defa
3070: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
3080: 65 72 76 65 72 20 69 73 20 69 6e 20 64 62 70 72 erver is in dbpr
3090: 65 70 20 61 74 20 22 20 28 63 6f 6d 6d 6f 6e 3a ep at " (common:
30a0: 68 75 6d 61 6e 2d 74 69 6d 65 29 29 0a 09 09 20 human-time))...
30b0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
30c0: 65 65 70 21 20 30 2e 35 29 29 20 3b 3b 20 77 61 eep! 0.5)) ;; wa
30d0: 73 20 32 35 20 73 65 63 20 62 75 74 20 74 68 61 s 25 sec but tha
30e0: 74 20 62 6c 6f 63 6b 65 64 20 74 68 69 6e 67 73 t blocked things
30f0: 20 66 72 6f 6d 20 73 74 61 72 74 69 6e 67 3f 0a from starting?.
3100: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
3110: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
3120: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 ult-log-port* "U
3130: 6e 61 62 6c 65 20 74 6f 20 67 65 74 20 73 65 72 nable to get ser
3140: 76 65 72 20 69 6e 66 6f 20 66 72 6f 6d 20 22 20 ver info from "
3150: 6c 6f 67 66 20 22 20 61 74 20 22 20 28 73 65 63 logf " at " (sec
3160: 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e onds->time-strin
3170: 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e g (current-secon
3180: 64 73 29 29 29 29 0a 09 09 20 62 61 64 2d 64 61 ds))))... bad-da
3190: 74 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 47 69 t))))))))..;; Gi
31a0: 76 65 6e 20 61 6e 20 61 72 65 61 20 70 61 74 68 ven an area path
31b0: 2c 20 20 73 74 61 72 74 20 61 20 73 65 72 76 65 , start a serve
31c0: 72 20 70 72 6f 63 65 73 73 20 20 20 20 23 23 23 r process ###
31d0: 20 4e 4f 54 45 20 23 23 23 20 3e 20 66 69 6c 65 NOTE ### > file
31e0: 20 32 3e 26 31 20 0a 3b 3b 20 69 66 20 74 68 65 2>&1 .;; if the
31f0: 20 74 61 72 67 65 74 2d 68 6f 73 74 20 69 73 20 target-host is
3200: 73 65 74 20 0a 3b 3b 20 74 72 79 20 72 75 6e 6e set .;; try runn
3210: 69 6e 67 20 6f 6e 20 74 68 61 74 20 68 6f 73 74 ing on that host
3220: 0a 3b 3b 20 20 20 69 6e 63 69 64 65 6e 74 61 6c .;; incidental
3230: 3a 20 72 6f 74 61 74 65 20 6c 6f 67 73 20 69 6e : rotate logs in
3240: 20 6c 6f 67 73 2f 20 64 69 72 2e 0a 3b 3b 0a 28 logs/ dir..;;.(
3250: 64 65 66 69 6e 65 20 20 28 74 74 3a 73 65 72 76 define (tt:serv
3260: 65 72 2d 70 72 6f 63 65 73 73 2d 72 75 6e 20 61 er-process-run a
3270: 72 65 61 70 61 74 68 20 74 65 73 74 73 75 69 74 reapath testsuit
3280: 65 20 6d 74 65 78 65 20 72 75 6e 2d 69 64 20 23 e mtexe run-id #
3290: 21 6b 65 79 20 28 70 72 6f 66 69 6c 65 2d 6d 6f !key (profile-mo
32a0: 64 65 20 22 22 29 29 20 3b 3b 20 61 72 65 61 70 de "")) ;; areap
32b0: 61 74 68 20 69 73 20 2a 74 6f 70 70 61 74 68 2a ath is *toppath*
32c0: 20 66 6f 72 20 61 20 67 69 76 65 6e 20 74 65 73 for a given tes
32d0: 74 73 75 69 74 65 20 61 72 65 61 0a 20 20 28 6c tsuite area. (l
32e0: 65 74 2a 20 28 28 6c 6f 67 66 69 6c 65 20 20 20 et* ((logfile
32f0: 28 63 6f 6e 63 20 61 72 65 61 70 61 74 68 20 22 (conc areapath "
3300: 2f 6c 6f 67 73 2f 73 65 72 76 65 72 2e 6c 6f 67 /logs/server.log
3310: 22 29 29 20 3b 3b 20 2d 22 20 63 75 72 72 2d 70 ")) ;; -" curr-p
3320: 69 64 20 22 2d 22 20 74 61 72 67 65 74 2d 68 6f id "-" target-ho
3330: 73 74 20 22 2e 6c 6f 67 22 29 29 0a 09 20 28 63 st ".log")).. (c
3340: 6d 64 6c 6e 20 20 20 20 20 28 63 6f 6e 63 0a 09 mdln (conc..
3350: 09 20 20 20 20 20 6d 74 65 78 65 0a 09 09 20 20 . mtexe...
3360: 20 20 20 22 20 2d 73 65 72 76 65 72 20 2d 20 22 " -server - "
3370: 3b 3b 20 28 6f 72 20 74 61 72 67 65 74 2d 68 6f ;; (or target-ho
3380: 73 74 20 22 2d 22 29 0a 09 09 20 20 20 20 20 22 st "-")... "
3390: 20 2d 6d 20 74 65 73 74 73 75 69 74 65 3a 22 20 -m testsuite:"
33a0: 74 65 73 74 73 75 69 74 65 0a 09 09 20 20 20 20 testsuite...
33b0: 20 22 20 2d 72 75 6e 2d 69 64 20 22 20 28 6f 72 " -run-id " (or
33c0: 20 72 75 6e 2d 69 64 20 22 6d 61 69 6e 22 29 0a run-id "main").
33d0: 09 09 20 20 20 20 20 22 20 2d 64 62 20 22 20 20 .. " -db "
33e0: 28 64 62 6d 6f 64 3a 72 75 6e 2d 69 64 2d 3e 64 (dbmod:run-id->d
33f0: 62 66 6e 61 6d 65 20 72 75 6e 2d 69 64 29 0a 09 bfname run-id)..
3400: 09 20 20 20 20 20 22 20 22 20 70 72 6f 66 69 6c . " " profil
3410: 65 2d 6d 6f 64 65 0a 09 09 20 20 20 20 20 29 29 e-mode... ))
3420: 29 20 3b 3b 20 28 63 6f 6e 63 20 22 20 3e 3e 20 ) ;; (conc " >>
3430: 22 20 6c 6f 67 66 69 6c 65 20 22 20 32 3e 26 31 " logfile " 2>&1
3440: 20 26 22 29 29 29 29 29 0a 20 20 20 20 3b 3b 20 &"))))). ;;
3450: 77 65 20 77 61 6e 74 20 74 68 65 20 72 65 6d 6f we want the remo
3460: 74 65 20 73 65 72 76 65 72 20 74 6f 20 73 74 61 te server to sta
3470: 72 74 20 69 6e 20 2a 74 6f 70 70 61 74 68 2a 20 rt in *toppath*
3480: 73 6f 20 70 75 73 68 20 74 68 65 72 65 0a 20 20 so push there.
3490: 20 20 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 (push-director
34a0: 79 20 61 72 65 61 70 61 74 68 29 0a 20 20 20 20 y areapath).
34b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 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 4e 46 4f 3a 20 54 72 79 69 6e 67 20 * "INFO: Trying
34e0: 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 20 to start server
34f0: 69 6e 20 74 63 70 20 6d 6f 64 65 20 28 22 20 63 in tcp mode (" c
3500: 6d 64 6c 6e 20 22 29 20 2e 2e 2e 22 29 0a 20 20 mdln ") ...").
3510: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3520: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3530: 72 74 2a 20 22 49 4e 46 4f 3a 20 73 74 61 72 74 rt* "INFO: start
3540: 69 6e 67 20 73 65 72 76 65 72 20 61 74 20 22 20 ing server at "
3550: 28 63 6f 6d 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 (common:human-ti
3560: 6d 65 29 29 0a 20 20 20 20 28 73 79 73 74 65 6d me)). (system
3570: 20 28 63 6f 6e 63 20 22 6e 62 66 61 6b 65 20 22 (conc "nbfake "
3580: 20 63 6d 64 6c 6e 29 29 0a 20 20 20 20 28 70 6f cmdln)). (po
3590: 70 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a 0a p-directory)))..
35a0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
35b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35e0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 63 70 20 ========.;; tcp
35f0: 63 6f 6e 6e 65 63 74 69 6f 6e 20 73 74 75 66 66 connection stuff
3600: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
3610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 =========..;; fi
3650: 6e 64 20 61 20 70 6f 72 74 20 61 6e 64 20 73 74 nd a port and st
3660: 61 72 74 20 74 63 70 2d 73 65 72 76 65 72 2e 20 art tcp-server.
3670: 54 68 69 73 20 6f 6e 6c 79 20 73 74 61 72 74 73 This only starts
3680: 20 74 68 65 20 74 63 70 20 70 6f 72 74 69 6f 6e the tcp portion
3690: 20 6f 66 0a 3b 3b 20 74 68 65 20 73 65 72 76 65 of.;; the serve
36a0: 72 2c 20 6c 6f 6f 6b 20 61 74 20 28 74 74 3a 73 r, look at (tt:s
36b0: 74 61 72 74 2d 73 65 72 76 65 72 20 2e 2e 2e 29 tart-server ...)
36c0: 20 61 62 6f 76 65 20 66 6f 72 20 74 68 65 20 65 above for the e
36d0: 6e 74 72 79 20 70 6f 69 6e 74 0a 3b 3b 20 66 6f ntry point.;; fo
36e0: 72 20 74 68 65 20 65 6e 74 69 72 65 20 73 65 72 r the entire ser
36f0: 76 65 72 20 73 79 73 74 65 6d 0a 3b 3b 0a 28 64 ver system.;;.(d
3700: 65 66 69 6e 65 20 28 74 74 3a 73 74 61 72 74 2d efine (tt:start-
3710: 74 63 70 2d 73 65 72 76 65 72 20 74 74 64 61 74 tcp-server ttdat
3720: 29 0a 20 20 28 73 65 74 75 70 2d 6c 69 73 74 65 ). (setup-liste
3730: 6e 65 72 20 74 74 64 61 74 29 0a 20 20 28 6c 65 ner ttdat). (le
3740: 74 2a 20 28 28 73 6f 63 6b 65 74 20 20 20 28 74 t* ((socket (t
3750: 74 2d 73 6f 63 6b 65 74 20 20 74 74 64 61 74 29 t-socket ttdat)
3760: 29 0a 09 20 28 68 61 6e 64 6c 65 72 20 20 28 74 ).. (handler (t
3770: 74 2d 68 61 6e 64 6c 65 72 20 74 74 64 61 74 29 t-handler ttdat)
3780: 29 29 0a 20 20 20 20 28 28 6d 61 6b 65 2d 74 63 )). ((make-tc
3790: 70 2d 73 65 72 76 65 72 20 73 6f 63 6b 65 74 20 p-server socket
37a0: 68 61 6e 64 6c 65 72 29 0a 20 20 20 20 20 23 74 handler). #t
37b0: 20 3b 3b 20 79 65 73 2c 20 73 65 6e 64 20 65 72 ;; yes, send er
37c0: 72 6f 72 20 6d 65 73 73 61 67 65 73 20 74 6f 20 ror messages to
37d0: 73 74 64 2d 65 72 72 0a 20 20 20 20 20 29 29 29 std-err. )))
37e0: 0a 0a 3b 3b 20 63 72 65 61 74 65 20 61 20 74 63 ..;; create a tc
37f0: 70 20 6c 69 73 74 65 6e 65 72 20 61 6e 64 20 72 p listener and r
3800: 65 74 75 72 6e 20 61 20 70 6f 70 75 6c 61 74 65 eturn a populate
3810: 64 20 75 64 61 74 20 73 74 72 75 63 74 20 77 69 d udat struct wi
3820: 74 68 0a 3b 3b 20 6d 79 20 70 6f 72 74 2c 20 61 th.;; my port, a
3830: 64 64 72 65 73 73 2c 20 68 6f 73 74 6e 61 6d 65 ddress, hostname
3840: 2c 20 70 69 64 20 65 74 63 2e 0a 3b 3b 20 72 65 , pid etc..;; re
3850: 74 75 72 6e 20 23 66 20 69 66 20 66 61 69 6c 20 turn #f if fail
3860: 74 6f 20 66 69 6e 64 20 61 20 70 6f 72 74 20 74 to find a port t
3870: 6f 20 61 6c 6c 6f 63 61 74 65 2e 0a 3b 3b 0a 3b o allocate..;;.;
3880: 3b 20 20 69 66 20 75 64 61 74 61 2d 69 6e 20 69 ; if udata-in i
3890: 73 20 23 66 20 63 72 65 61 74 65 20 74 68 65 20 s #f create the
38a0: 72 65 63 6f 72 64 0a 3b 3b 20 20 69 66 20 74 68 record.;; if th
38b0: 65 72 65 20 69 73 20 61 6c 72 65 61 64 79 20 61 ere is already a
38c0: 20 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 72 serv-listener r
38d0: 65 74 75 72 6e 20 74 68 65 20 75 64 61 74 61 0a eturn the udata.
38e0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 74 75 ;;.(define (setu
38f0: 70 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e 6e p-listener uconn
3900: 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 70 6f 72 #!optional (por
3910: 74 20 34 32 34 32 29 29 0a 20 20 28 61 73 73 65 t 4242)). (asse
3920: 72 74 20 28 74 74 3f 20 75 63 6f 6e 6e 29 20 22 rt (tt? uconn) "
3930: 46 41 54 41 4c 3a 20 73 65 74 75 70 2d 6c 69 73 FATAL: setup-lis
3940: 74 65 6e 65 72 20 63 61 6c 6c 65 64 20 77 69 74 tener called wit
3950: 68 20 77 72 6f 6e 67 20 73 74 72 75 63 74 20 22 h wrong struct "
3960: 75 63 6f 6e 6e 29 0a 20 20 28 68 61 6e 64 6c 65 uconn). (handle
3970: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 -exceptions. e
3980: 78 6e 0a 20 20 20 28 69 66 20 28 3c 20 70 6f 72 xn. (if (< por
3990: 74 20 36 35 35 33 35 29 0a 20 20 20 20 20 20 20 t 65535).
39a0: 28 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 (setup-listener
39b0: 75 63 6f 6e 6e 20 28 2b 20 70 6f 72 74 20 31 29 uconn (+ port 1)
39c0: 29 0a 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 ). #f).
39d0: 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 74 65 6e 65 (connect-listene
39e0: 72 20 75 63 6f 6e 6e 20 70 6f 72 74 29 29 29 0a r uconn port))).
39f0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 6e 65 63 .(define (connec
3a00: 74 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e 6e t-listener uconn
3a10: 20 70 6f 72 74 29 0a 20 20 3b 3b 20 28 74 63 70 port). ;; (tcp
3a20: 2d 6c 69 73 74 65 6e 65 72 2d 73 6f 63 6b 65 74 -listener-socket
3a30: 20 4c 49 53 54 45 4e 45 52 29 28 73 6f 63 6b 65 LISTENER)(socke
3a40: 74 2d 6e 61 6d 65 20 73 6f 29 0a 20 20 3b 3b 20 t-name so). ;;
3a50: 73 6f 63 6b 61 64 64 72 2d 61 64 64 72 65 73 73 sockaddr-address
3a60: 2c 20 73 6f 63 6b 61 64 64 72 2d 70 6f 72 74 2c , sockaddr-port,
3a70: 20 73 6f 63 6b 61 64 64 72 2d 3e 73 74 72 69 6e sockaddr->strin
3a80: 67 0a 20 20 28 6c 65 74 2a 20 28 28 74 6c 73 6e g. (let* ((tlsn
3a90: 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 70 6f 72 (tcp-listen por
3aa0: 74 20 31 30 30 30 20 23 66 29 29 20 3b 3b 20 28 t 1000 #f)) ;; (
3ab0: 74 63 70 2d 6c 69 73 74 65 6e 20 54 43 50 50 4f tcp-listen TCPPO
3ac0: 52 54 20 5b 42 41 43 4b 4c 4f 47 20 5b 48 4f 53 RT [BACKLOG [HOS
3ad0: 54 5d 5d 29 0a 09 20 28 61 64 64 72 20 20 28 74 T]]).. (addr (t
3ae0: 74 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 t:get-best-guess
3af0: 2d 61 64 64 72 65 73 73 20 28 67 65 74 2d 68 6f -address (get-ho
3b00: 73 74 2d 6e 61 6d 65 29 29 29 29 20 3b 3b 20 28 st-name)))) ;; (
3b10: 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 get-my-best-addr
3b20: 65 73 73 29 29 29 20 3b 3b 20 28 68 6f 73 74 69 ess))) ;; (hosti
3b30: 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 nfo-addresses (h
3b40: 6f 73 74 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 ost-information
3b50: 28 63 75 72 72 65 6e 74 2d 68 6f 73 74 6e 61 6d (current-hostnam
3b60: 65 29 29 29 0a 20 20 20 20 28 74 74 2d 70 6f 72 e))). (tt-por
3b70: 74 2d 73 65 74 21 20 20 20 20 20 20 75 63 6f 6e t-set! ucon
3b80: 6e 20 70 6f 72 74 29 0a 20 20 20 20 28 74 74 2d n port). (tt-
3b90: 68 6f 73 74 2d 73 65 74 21 20 20 20 20 20 20 75 host-set! u
3ba0: 63 6f 6e 6e 20 61 64 64 72 29 0a 20 20 20 20 28 conn addr). (
3bb0: 74 74 2d 68 6f 73 74 2d 70 6f 72 74 2d 73 65 74 tt-host-port-set
3bc0: 21 20 75 63 6f 6e 6e 20 28 63 6f 6e 63 20 61 64 ! uconn (conc ad
3bd0: 64 72 22 3a 22 70 6f 72 74 29 29 0a 20 20 20 20 dr":"port)).
3be0: 28 74 74 2d 73 6f 63 6b 65 74 2d 73 65 74 21 20 (tt-socket-set!
3bf0: 20 20 20 75 63 6f 6e 6e 20 74 6c 73 6e 29 0a 20 uconn tlsn).
3c00: 20 20 20 75 63 6f 6e 6e 29 29 0a 0a 0a 0a 3b 3b uconn))....;;
3c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c50: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 75 74 69 6c 73 0a ======.;; utils.
3c60: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
3c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ca0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e ========..;; Gen
3cb0: 65 72 61 74 65 20 61 20 75 6e 69 71 75 65 20 73 erate a unique s
3cc0: 69 67 6e 61 74 75 72 65 20 66 6f 72 20 74 68 69 ignature for thi
3cd0: 73 20 73 65 72 76 65 72 0a 28 64 65 66 69 6e 65 s server.(define
3ce0: 20 28 74 74 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 (tt:mk-signatur
3cf0: 65 20 61 72 65 61 70 61 74 68 29 0a 20 20 28 6d e areapath). (m
3d00: 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 74 essage-digest-st
3d10: 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 74 ring (md5-primit
3d20: 69 76 65 29 20 0a 09 09 09 20 28 77 69 74 68 2d ive) .... (with-
3d30: 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 output-to-string
3d40: 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 61 20 28 .... (lambda (
3d50: 29 0a 09 09 09 20 20 20 20 20 28 77 72 69 74 65 ).... (write
3d60: 20 28 6c 69 73 74 20 61 72 65 61 70 61 74 68 0a (list areapath.
3d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d90: 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 (curre
3da0: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 0a 09 nt-process-id)..
3db0: 09 09 09 09 20 20 28 61 72 67 76 29 29 29 29 29 .... (argv)))))
3dc0: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 ))...(define (tt
3dd0: 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d :get-best-guess-
3de0: 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 address hostname
3df0: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 ). (let ((res #
3e00: 66 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 f)). (for-eac
3e10: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
3e20: 28 61 64 72 29 0a 20 20 20 20 20 20 20 28 69 66 (adr). (if
3e30: 20 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 (not (eq? (u8ve
3e40: 63 74 6f 72 2d 72 65 66 20 61 64 72 20 30 29 20 ctor-ref adr 0)
3e50: 31 32 37 29 29 0a 09 20 20 20 28 73 65 74 21 20 127)).. (set!
3e60: 72 65 73 20 61 64 72 29 29 29 0a 20 20 20 20 20 res adr))).
3e70: 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 63 61 ;; NOTE: This ca
3e80: 6e 20 66 61 69 6c 20 77 68 65 6e 20 74 68 65 72 n fail when ther
3e90: 65 20 69 73 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 e is no mention
3ea0: 6f 66 20 74 68 65 20 68 6f 73 74 20 69 6e 20 2f of the host in /
3eb0: 65 74 63 2f 68 6f 73 74 73 2e 20 46 49 58 4d 45 etc/hosts. FIXME
3ec0: 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c . (vector->l
3ed0: 69 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 ist (hostinfo-ad
3ee0: 64 72 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d dresses (hostnam
3ef0: 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 68 6f 73 74 e->hostinfo host
3f00: 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 28 73 74 name)))). (st
3f10: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
3f20: 20 0a 20 20 20 20 20 28 6d 61 70 20 6e 75 6d 62 . (map numb
3f30: 65 72 2d 3e 73 74 72 69 6e 67 0a 09 20 20 28 75 er->string.. (u
3f40: 38 76 65 63 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 8vector->list..
3f50: 20 20 28 69 66 20 72 65 73 20 72 65 73 20 28 68 (if res res (h
3f60: 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 ostname->ip host
3f70: 6e 61 6d 65 29 29 29 29 20 22 2e 22 29 29 29 0a name)))) "."))).
3f80: 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 67 65 74 .(define (tt:get
3f90: 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 61 72 -servinfo-dir ar
3fa0: 65 61 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 eapath). (let*
3fb0: 28 28 73 70 61 74 68 20 28 63 6f 6e 63 20 61 72 ((spath (conc ar
3fc0: 65 61 70 61 74 68 22 2f 2e 73 65 72 76 69 6e 66 eapath"/.servinf
3fd0: 6f 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e o"))). (if (n
3fe0: 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f ot (file-exists?
3ff0: 20 73 70 61 74 68 29 29 0a 09 28 63 72 65 61 74 spath))..(creat
4000: 65 2d 64 69 72 65 63 74 6f 72 79 20 73 70 61 74 e-directory spat
4010: 68 20 23 74 29 29 0a 20 20 20 20 73 70 61 74 68 h #t)). spath
4020: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
4030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
4070: 6e 65 74 77 6f 72 6b 20 75 74 69 6c 69 74 69 65 network utilitie
4080: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
4090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e ==========..;; N
40d0: 4f 54 45 3a 20 4c 6f 6f 6b 20 61 74 20 61 64 64 OTE: Look at add
40e0: 72 65 73 73 2d 69 6e 66 6f 20 65 67 67 20 61 73 ress-info egg as
40f0: 20 61 6c 74 65 72 6e 61 74 69 76 65 20 74 6f 20 alternative to
4100: 73 6f 6d 65 20 6f 66 20 74 68 69 73 0a 0a 28 64 some of this..(d
4110: 65 66 69 6e 65 20 28 72 61 74 65 2d 69 70 20 69 efine (rate-ip i
4120: 70 61 64 64 72 29 0a 20 20 28 72 65 67 65 78 2d paddr). (regex-
4130: 63 61 73 65 20 69 70 61 64 64 72 0a 20 20 20 20 case ipaddr.
4140: 28 20 22 5e 31 32 37 5c 5c 2e 2e 2a 22 20 5f 20 ( "^127\\..*" _
4150: 30 20 29 0a 20 20 20 20 28 20 22 5e 28 31 30 5c 0 ). ( "^(10\
4160: 5c 2e 30 7c 31 39 32 5c 5c 2e 31 36 38 29 5c 5c \.0|192\\.168)\\
4170: 2e 2e 2a 22 20 5f 20 31 20 29 0a 20 20 20 20 28 ..*" _ 1 ). (
4180: 20 65 6c 73 65 20 32 20 29 20 29 29 0a 0a 3b 3b else 2 ) ))..;;
4190: 20 43 68 61 6e 67 65 20 74 68 69 73 20 74 6f 20 Change this to
41a0: 62 69 61 73 20 66 6f 72 20 61 64 64 72 65 73 73 bias for address
41b0: 65 73 20 77 69 74 68 20 61 20 72 65 61 73 6f 6e es with a reason
41c0: 61 62 6c 65 20 62 72 6f 61 64 63 61 73 74 20 76 able broadcast v
41d0: 61 6c 75 65 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 alue?.;;.(define
41e0: 20 28 69 70 2d 70 72 65 66 2d 6c 65 73 73 3f 20 (ip-pref-less?
41f0: 61 20 62 29 0a 20 20 28 3e 20 28 72 61 74 65 2d a b). (> (rate-
4200: 69 70 20 61 29 20 28 72 61 74 65 2d 69 70 20 62 ip a) (rate-ip b
4210: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 )))..(define (ge
4220: 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 73 t-my-best-addres
4230: 73 29 0a 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d s). (let ((all-
4240: 6d 79 2d 61 64 64 72 65 73 73 65 73 20 28 67 65 my-addresses (ge
4250: 74 2d 61 6c 6c 2d 69 70 73 29 29 29 0a 20 20 20 t-all-ips))).
4260: 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e 75 (cond. ((nu
4270: 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 ll? all-my-addre
4280: 73 73 65 73 29 0a 20 20 20 20 20 20 28 67 65 74 sses). (get
4290: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 20 20 20 20 -host-name))
42a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
42b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
42c0: 20 20 20 20 20 20 3b 3b 20 6e 6f 20 69 6e 74 65 ;; no inte
42d0: 72 66 61 63 65 73 3f 0a 20 20 20 20 20 28 28 65 rfaces?. ((e
42e0: 71 3f 20 28 6c 65 6e 67 74 68 20 61 6c 6c 2d 6d q? (length all-m
42f0: 79 2d 61 64 64 72 65 73 73 65 73 29 20 31 29 0a y-addresses) 1).
4300: 20 20 20 20 20 20 28 63 61 72 20 61 6c 6c 2d 6d (car all-m
4310: 79 2d 61 64 64 72 65 73 73 65 73 29 29 20 20 20 y-addresses))
4320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4330: 20 20 20 3b 3b 20 6f 6e 6c 79 20 6f 6e 65 20 74 ;; only one t
4340: 6f 20 63 68 6f 6f 73 65 20 66 72 6f 6d 2c 20 6a o choose from, j
4350: 75 73 74 20 67 6f 20 77 69 74 68 20 69 74 0a 20 ust go with it.
4360: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
4370: 28 63 61 72 20 28 73 6f 72 74 20 61 6c 6c 2d 6d (car (sort all-m
4380: 79 2d 61 64 64 72 65 73 73 65 73 20 69 70 2d 70 y-addresses ip-p
4390: 72 65 66 2d 6c 65 73 73 3f 29 29 29 29 29 29 0a ref-less?)))))).
43a0: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 61 6c .(define (get-al
43b0: 6c 2d 69 70 73 2d 73 6f 72 74 65 64 29 0a 20 20 l-ips-sorted).
43c0: 28 73 6f 72 74 20 28 67 65 74 2d 61 6c 6c 2d 69 (sort (get-all-i
43d0: 70 73 29 20 69 70 2d 70 72 65 66 2d 6c 65 73 73 ps) ip-pref-less
43e0: 3f 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 ?))..(define (ge
43f0: 74 2d 61 6c 6c 2d 69 70 73 29 0a 20 20 28 6d 61 t-all-ips). (ma
4400: 70 20 61 64 64 72 65 73 73 2d 69 6e 66 6f 2d 68 p address-info-h
4410: 6f 73 74 0a 20 20 20 20 20 20 20 28 66 69 6c 74 ost. (filt
4420: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
4430: 09 20 28 65 71 75 61 6c 3f 20 28 61 64 64 72 65 . (equal? (addre
4440: 73 73 2d 69 6e 66 6f 2d 74 79 70 65 20 78 29 20 ss-info-type x)
4450: 22 74 63 70 22 29 29 0a 09 20 20 20 20 20 20 20 "tcp"))..
4460: 28 61 64 64 72 65 73 73 2d 69 6e 66 6f 73 20 28 (address-infos (
4470: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 get-host-name)))
4480: 29 29 0a 0a 29 0a ))..).