Artifact
4ba3510aa8e0dcea64a3ec698a735e1e7012c10f:
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 0a es commonmod))..
03e0: 28 6d 6f 64 75 6c 65 20 74 63 70 2d 74 72 61 6e (module tcp-tran
03f0: 73 70 6f 72 74 6d 6f 64 0a 09 2a 0a 09 0a 20 20 sportmod..*...
0400: 28 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 0a 09 (import scheme..
0410: 20 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 (prefix sqlite
0420: 33 20 73 71 6c 69 74 65 33 3a 29 0a 09 20 20 63 3 sqlite3:).. c
0430: 68 69 63 6b 65 6e 0a 09 20 20 64 61 74 61 2d 73 hicken.. data-s
0440: 74 72 75 63 74 75 72 65 73 0a 0a 09 20 20 61 64 tructures... ad
0450: 64 72 65 73 73 2d 69 6e 66 6f 0a 09 20 20 64 69 dress-info.. di
0460: 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 0a 09 20 rectory-utils..
0470: 20 65 78 74 72 61 73 0a 09 20 20 66 69 6c 65 73 extras.. files
0480: 0a 09 20 20 68 6f 73 74 69 6e 66 6f 0a 09 20 20 .. hostinfo..
0490: 6d 61 74 63 68 61 62 6c 65 0a 09 20 20 6d 64 35 matchable.. md5
04a0: 0a 09 20 20 6d 65 73 73 61 67 65 2d 64 69 67 65 .. message-dige
04b0: 73 74 0a 09 20 20 70 6f 72 74 73 0a 09 20 20 70 st.. ports.. p
04c0: 6f 73 69 78 0a 09 20 20 72 65 67 65 78 0a 09 20 osix.. regex..
04d0: 20 72 65 67 65 78 2d 63 61 73 65 0a 09 20 20 73 regex-case.. s
04e0: 72 66 69 2d 31 0a 09 20 20 73 72 66 69 2d 31 38 rfi-1.. srfi-18
04f0: 0a 09 20 20 73 72 66 69 2d 34 0a 09 20 20 73 72 .. srfi-4.. sr
0500: 66 69 2d 36 39 0a 09 20 20 73 74 61 63 6b 0a 09 fi-69.. stack..
0510: 20 20 74 79 70 65 64 2d 72 65 63 6f 72 64 73 0a typed-records.
0520: 09 20 20 74 63 70 2d 73 65 72 76 65 72 0a 09 20 . tcp-server..
0530: 20 74 63 70 0a 09 20 20 0a 09 20 20 63 6f 6d 6d tcp.. .. comm
0540: 6f 6e 6d 6f 64 0a 09 20 20 64 65 62 75 67 70 72 onmod.. debugpr
0550: 69 6e 74 0a 09 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d int..)..;;======
0560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05a0: 0a 3b 3b 20 63 6c 69 65 6e 74 0a 3b 3b 3d 3d 3d .;; client.;;===
05b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 ===..;; (define
0600: 6b 65 65 70 2d 61 67 65 2d 70 61 72 61 6d 20 28 keep-age-param (
0610: 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 20 31 make-parameter 1
0620: 30 29 29 20 3b 3b 20 71 69 66 20 66 69 6c 65 20 0)) ;; qif file
0630: 61 67 65 2c 20 69 66 20 6f 76 65 72 20 6d 6f 76 age, if over mov
0640: 65 20 74 6f 20 61 74 74 69 63 0a 0a 3b 3b 20 74 e to attic..;; t
0650: 68 65 20 63 6c 69 65 6e 74 20 73 69 64 65 20 73 he client side s
0660: 74 72 75 63 74 0a 3b 3b 0a 28 64 65 66 73 74 72 truct.;;.(defstr
0670: 75 63 74 20 74 74 0a 20 20 3b 3b 20 61 6c 6c 0a uct tt. ;; all.
0680: 20 20 28 61 72 65 61 70 61 74 68 20 23 66 29 0a (areapath #f).
0690: 20 20 3b 3b 20 63 6c 69 65 6e 74 20 72 65 6c 61 ;; client rela
06a0: 74 65 64 0a 20 20 28 63 6f 6e 6e 73 20 28 6d 61 ted. (conns (ma
06b0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
06c0: 3b 3b 20 64 62 66 6e 61 6d 65 20 2d 3e 20 63 6f ;; dbfname -> co
06d0: 6e 6e 0a 20 20 29 0a 0a 28 64 65 66 73 74 72 75 nn. )..(defstru
06e0: 63 74 20 74 74 2d 63 6f 6e 6e 0a 20 20 68 6f 73 ct tt-conn. hos
06f0: 74 0a 20 20 70 6f 72 74 0a 20 20 64 62 66 6e 61 t. port. dbfna
0700: 6d 65 0a 29 0a 0a 28 64 65 66 73 74 72 75 63 74 me.)..(defstruct
0710: 20 74 74 2d 73 72 76 0a 20 20 3b 3b 20 73 65 72 tt-srv. ;; ser
0720: 76 65 72 20 72 65 6c 61 74 65 64 0a 20 20 28 61 ver related. (a
0730: 72 65 61 70 61 74 68 20 20 20 20 20 23 66 29 0a reapath #f).
0740: 20 20 28 68 6f 73 74 20 20 20 20 20 20 20 20 20 (host
0750: 23 66 29 0a 20 20 28 70 6f 72 74 20 20 20 20 20 #f). (port
0760: 20 20 20 20 23 66 29 0a 20 20 28 63 6f 6e 6e 20 #f). (conn
0770: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 63 #f). (c
0780: 6c 65 61 6e 75 70 2d 70 72 6f 63 20 23 66 29 0a leanup-proc #f).
0790: 20 20 28 68 61 6e 64 6c 65 72 20 20 20 20 20 20 (handler
07a0: 23 66 29 20 3b 3b 20 72 65 63 65 69 76 65 73 20 #f) ;; receives
07b0: 64 61 74 61 20 61 6e 64 20 72 65 73 70 6f 6e 64 data and respond
07c0: 73 0a 20 20 28 73 6f 63 6b 65 74 20 20 20 20 20 s. (socket
07d0: 20 20 23 66 29 0a 20 20 28 74 68 72 65 61 64 20 #f). (thread
07e0: 20 20 20 20 20 20 23 66 29 0a 20 20 28 68 6f 73 #f). (hos
07f0: 74 2d 70 6f 72 74 20 20 20 20 23 66 29 0a 20 20 t-port #f).
0800: 28 63 6d 64 2d 74 68 72 65 61 64 20 20 20 23 66 (cmd-thread #f
0810: 29 0a 20 20 29 0a 0a 28 64 65 66 69 6e 65 20 28 ). )..(define (
0820: 74 74 3a 6d 61 6b 65 2d 72 65 6d 6f 74 65 20 61 tt:make-remote a
0830: 72 65 61 70 61 74 68 29 0a 20 20 28 6d 61 6b 65 reapath). (make
0840: 2d 74 74 20 61 72 65 61 3a 20 61 72 65 61 70 61 -tt area: areapa
0850: 74 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 th))..(define (t
0860: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
0870: 2d 74 6f 2d 73 65 72 76 65 72 20 74 74 64 61 74 -to-server ttdat
0880: 29 0a 20 20 23 66 29 0a 0a 3b 3b 20 63 6c 69 65 ). #f)..;; clie
0890: 6e 74 20 73 69 64 65 20 68 61 6e 64 6c 65 72 0a nt side handler.
08a0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 68 ;;.(define (tt:h
08b0: 61 6e 64 6c 65 72 20 72 75 6e 72 65 6d 6f 74 65 andler runremote
08c0: 20 63 6d 64 20 72 69 64 20 70 61 72 61 6d 73 20 cmd rid params
08d0: 61 74 74 65 6d 70 74 6e 75 6d 20 61 72 65 61 2d attemptnum area-
08e0: 64 61 74 20 61 72 65 61 70 61 74 68 20 72 65 61 dat areapath rea
08f0: 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e 61 donly-mode dbfna
0900: 6d 65 29 0a 20 20 3b 3b 20 4e 4f 54 45 3a 20 61 me). ;; NOTE: a
0910: 72 65 61 70 61 74 68 20 69 73 20 70 61 73 73 65 reapath is passe
0920: 64 20 69 6e 20 61 6e 64 20 69 6e 20 74 74 20 73 d in and in tt s
0930: 74 72 75 63 74 2e 20 57 65 27 6c 6c 20 75 73 65 truct. We'll use
0940: 20 70 61 73 73 65 64 20 69 6e 20 76 61 6c 75 65 passed in value
0950: 20 66 6f 72 20 6e 6f 77 2e 0a 20 20 28 6c 65 74 for now.. (let
0960: 2a 20 28 28 63 6f 6e 6e 20 28 68 61 73 68 2d 74 * ((conn (hash-t
0970: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
0980: 20 28 74 74 2d 63 6f 6e 6e 73 20 72 75 6e 72 65 (tt-conns runre
0990: 6d 6f 74 65 29 20 64 62 66 6e 61 6d 65 20 23 66 mote) dbfname #f
09a0: 29 29 29 0a 20 20 20 20 28 69 66 20 63 6f 6e 6e ))). (if conn
09b0: 0a 09 3b 3b 20 68 61 76 65 20 63 6f 6e 6e 65 63 ..;; have connec
09c0: 74 69 6f 6e 2c 20 63 61 6c 6c 20 74 68 65 20 73 tion, call the s
09d0: 65 72 76 65 72 0a 09 28 6c 65 74 2a 20 28 28 72 erver..(let* ((r
09e0: 65 73 20 28 74 74 3a 73 65 6e 64 2d 72 65 63 65 es (tt:send-rece
09f0: 69 76 65 20 72 75 6e 72 65 6d 6f 74 65 20 63 6f ive runremote co
0a00: 6e 6e 20 63 6d 64 20 72 69 64 20 70 61 72 61 6d nn cmd rid param
0a10: 73 29 29 29 0a 09 20 20 28 63 6f 6e 64 0a 09 20 s))).. (cond..
0a20: 20 20 28 28 6d 65 6d 62 65 72 20 72 65 73 20 27 ((member res '
0a30: 28 62 75 73 79 20 73 74 61 72 74 69 6e 67 29 29 (busy starting))
0a40: 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c .. (thread-sl
0a50: 65 65 70 21 20 31 29 0a 09 20 20 20 20 28 74 74 eep! 1).. (tt
0a60: 3a 68 61 6e 64 6c 65 72 20 20 72 75 6e 72 65 6d :handler runrem
0a70: 6f 74 65 20 63 6d 64 20 72 69 64 20 70 61 72 61 ote cmd rid para
0a80: 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 20 61 72 ms attemptnum ar
0a90: 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 68 20 ea-dat areapath
0aa0: 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 62 readonly-mode db
0ab0: 66 6e 61 6d 65 29 29 0a 09 20 20 20 28 65 6c 73 fname)).. (els
0ac0: 65 0a 09 20 20 20 20 72 65 73 29 29 29 0a 09 3b e.. res)))..;
0ad0: 3b 20 6e 6f 20 63 6f 6e 6e 20 79 65 74 2c 20 66 ; no conn yet, f
0ae0: 69 6e 64 20 61 6e 64 20 6f 72 20 73 74 61 72 74 ind and or start
0af0: 20 61 6e 64 20 66 69 6e 64 20 61 20 73 65 72 76 and find a serv
0b00: 65 72 0a 09 28 6c 65 74 2a 20 28 28 73 65 72 76 er..(let* ((serv
0b10: 65 72 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 er (tt:find-serv
0b20: 65 72 20 61 72 65 61 70 61 74 68 20 64 62 66 6e er areapath dbfn
0b30: 61 6d 65 29 29 29 0a 09 20 20 28 69 66 20 73 65 ame))).. (if se
0b40: 72 76 65 72 0a 09 20 20 20 20 20 20 28 6c 65 74 rver.. (let
0b50: 2a 20 28 28 63 6f 6e 6e 20 28 74 74 3a 63 6c 69 * ((conn (tt:cli
0b60: 65 6e 74 2d 63 6f 6e 6e 65 63 74 2d 74 6f 2d 73 ent-connect-to-s
0b70: 65 72 76 65 72 20 73 65 72 76 65 72 29 29 29 0a erver server))).
0b80: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
0b90: 74 21 20 28 74 74 2d 63 6f 6e 6e 73 20 72 75 6e t! (tt-conns run
0ba0: 72 65 6d 6f 74 65 29 20 64 62 66 6e 61 6d 65 20 remote) dbfname
0bb0: 63 6f 6e 6e 29 0a 09 09 28 74 74 3a 68 61 6e 64 conn)...(tt:hand
0bc0: 6c 65 72 20 20 72 75 6e 72 65 6d 6f 74 65 20 63 ler runremote c
0bd0: 6d 64 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 md rid params at
0be0: 74 65 6d 70 74 6e 75 6d 20 61 72 65 61 2d 64 61 temptnum area-da
0bf0: 74 20 61 72 65 61 70 61 74 68 20 72 65 61 64 6f t areapath reado
0c00: 6e 6c 79 2d 6d 6f 64 65 20 64 62 66 6e 61 6d 65 nly-mode dbfname
0c10: 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 )).. ;; no
0c20: 73 65 72 76 65 72 2c 20 74 72 79 20 74 6f 20 73 server, try to s
0c30: 74 61 72 74 20 6f 6e 65 0a 09 20 20 20 20 20 20 tart one..
0c40: 28 62 65 67 69 6e 0a 09 09 28 74 74 3a 73 74 61 (begin...(tt:sta
0c50: 72 74 2d 73 65 72 76 65 72 20 61 72 65 61 70 61 rt-server areapa
0c60: 74 68 20 64 62 66 6e 61 6d 65 29 0a 09 09 28 74 th dbfname)...(t
0c70: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
0c80: 09 09 28 74 74 3a 68 61 6e 64 6c 65 72 20 20 72 ..(tt:handler r
0c90: 75 6e 72 65 6d 6f 74 65 20 63 6d 64 20 72 69 64 unremote cmd rid
0ca0: 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e params attemptn
0cb0: 75 6d 20 61 72 65 61 2d 64 61 74 20 61 72 65 61 um area-dat area
0cc0: 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f path readonly-mo
0cd0: 64 65 20 64 62 66 6e 61 6d 65 29 29 29 29 29 29 de dbfname))))))
0ce0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 62 )..(define (tt:b
0cf0: 69 64 2d 66 6f 72 2d 73 65 72 76 65 72 73 68 69 id-for-servershi
0d00: 70 20 72 75 6e 2d 69 64 29 0a 20 20 23 66 29 0a p run-id). #f).
0d10: 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 67 65 74 .(define (tt:get
0d20: 2d 63 75 72 72 65 6e 74 2d 73 65 72 76 65 72 20 -current-server
0d30: 72 75 6e 2d 69 64 29 0a 20 20 23 66 29 0a 0a 28 run-id). #f)..(
0d40: 64 65 66 69 6e 65 20 28 74 74 3a 73 65 6e 64 2d define (tt:send-
0d50: 72 65 63 65 69 76 65 20 74 74 64 61 74 20 63 6f receive ttdat co
0d60: 6e 6e 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 nn cmd run-id pa
0d70: 72 61 6d 73 29 0a 20 20 23 66 29 0a 0a 3b 3b 3d rams). #f)..;;=
0d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0dc0: 3d 3d 3d 3d 3d 0a 3b 3b 20 73 65 72 76 65 72 0a =====.;; server.
0dd0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0e10: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
0e20: 65 20 28 74 74 3a 73 79 6e 63 2d 64 62 73 20 74 e (tt:sync-dbs t
0e30: 74 64 61 74 29 0a 20 20 23 66 29 0a 0a 3b 3b 20 tdat). #f)..;;
0e40: 73 74 61 72 74 20 74 68 65 20 6c 69 73 74 65 6e start the listen
0e50: 65 72 20 61 6e 64 20 73 74 61 72 74 20 72 65 73 er and start res
0e60: 70 6f 6e 64 69 6e 67 20 74 6f 20 72 65 71 75 65 ponding to reque
0e70: 73 74 73 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 sts.;;.;; NOTE:
0e80: 6f 72 67 61 6e 69 73 65 20 62 79 20 64 62 66 6e organise by dbfn
0e90: 61 6d 65 2c 20 6e 6f 74 20 72 75 6e 2d 69 64 20 ame, not run-id
0ea0: 73 6f 20 77 65 20 64 6f 6e 27 74 20 6e 65 65 64 so we don't need
0eb0: 0a 3b 3b 20 20 20 20 20 20 20 74 6f 20 70 75 6c .;; to pul
0ec0: 6c 20 69 6e 20 6d 6f 72 65 20 6d 6f 64 75 6c 65 l in more module
0ed0: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 74 s.;;.(define (tt
0ee0: 3a 73 74 61 72 74 2d 73 65 72 76 65 72 20 61 72 :start-server ar
0ef0: 65 61 70 61 74 68 20 64 62 66 6e 61 6d 65 20 68 eapath dbfname h
0f00: 61 6e 64 6c 65 72 29 0a 20 20 3b 3b 20 69 73 20 andler). ;; is
0f10: 74 68 65 72 65 20 61 6c 72 65 61 64 79 20 61 20 there already a
0f20: 73 65 72 76 65 72 20 66 6f 72 20 74 68 69 73 20 server for this
0f30: 64 62 66 69 6c 65 3f 20 54 68 65 6e 20 65 78 69 dbfile? Then exi
0f40: 74 2e 0a 20 20 28 6c 65 74 2a 20 28 28 74 74 64 t.. (let* ((ttd
0f50: 61 74 20 20 28 6d 61 6b 65 2d 74 74 2d 73 72 76 at (make-tt-srv
0f60: 20 61 72 65 61 70 61 74 68 3a 20 61 72 65 61 70 areapath: areap
0f70: 61 74 68 29 29 0a 09 20 28 73 65 72 76 65 72 73 ath)).. (servers
0f80: 20 28 74 74 3a 66 69 6e 64 2d 73 65 72 76 65 72 (tt:find-server
0f90: 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 29 ttdat dbfname))
0fa0: 29 0a 20 20 20 20 28 74 74 2d 73 72 76 2d 68 61 ). (tt-srv-ha
0fb0: 6e 64 6c 65 72 2d 73 65 74 21 20 74 74 64 61 74 ndler-set! ttdat
0fc0: 20 68 61 6e 64 6c 65 72 29 0a 20 20 20 20 28 69 handler). (i
0fd0: 66 20 28 6e 75 6c 6c 3f 20 73 65 72 76 65 72 73 f (null? servers
0fe0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 74 74 )..(begin.. (tt
0ff0: 3a 73 74 61 72 74 2d 74 63 70 2d 73 65 72 76 65 :start-tcp-serve
1000: 72 20 74 74 64 61 74 29 20 3b 3b 20 73 74 61 72 r ttdat) ;; star
1010: 74 20 74 68 65 20 74 63 70 2d 73 65 72 76 65 72 t the tcp-server
1020: 20 77 68 69 63 68 20 61 70 70 6c 69 65 73 20 68 which applies h
1030: 61 6e 64 6c 65 72 20 74 6f 20 69 6e 63 6f 6d 69 andler to incomi
1040: 6e 67 20 64 61 74 61 0a 09 20 20 28 74 74 3a 6b ng data.. (tt:k
1050: 65 65 70 2d 72 75 6e 6e 69 6e 67 20 74 74 64 61 eep-running ttda
1060: 74 20 64 62 66 6e 61 6d 65 29 29 0a 09 28 62 65 t dbfname))..(be
1070: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
1080: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
1090: 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 og-port* "INFO:
10a0: 66 6f 75 6e 64 20 73 65 72 76 65 72 28 73 29 20 found server(s)
10b0: 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 already running
10c0: 66 6f 72 20 64 62 20 22 64 62 66 6e 61 6d 65 22 for db "dbfname"
10d0: 2c 20 22 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 , "(string-inter
10e0: 73 70 65 72 73 65 20 73 65 72 76 65 72 73 20 22 sperse servers "
10f0: 2c 22 29 22 20 45 78 69 74 69 6e 67 2e 22 29 0a ,")" Exiting.").
1100: 09 20 20 28 65 78 69 74 29 29 29 29 29 0a 0a 28 . (exit)))))..(
1110: 28 6d 61 6b 65 2d 74 63 70 2d 73 65 72 76 65 72 (make-tcp-server
1120: 20 0a 20 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 . (tcp-listen
1130: 36 35 30 34 29 20 0a 20 20 28 6c 61 6d 62 64 61 6504) . (lambda
1140: 20 28 29 20 0a 20 20 20 20 28 77 72 69 74 65 2d () . (write-
1150: 6c 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 73 line (seconds->s
1160: 74 72 69 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 tring (current-s
1170: 65 63 6f 6e 64 73 29 29 29 29 29 0a 20 23 74 29 econds))))). #t)
1180: 0a 0a 3b 3b 20 66 69 6e 64 20 61 20 70 6f 72 74 ..;; find a port
1190: 20 61 6e 64 20 73 74 61 72 74 20 74 63 70 2d 73 and start tcp-s
11a0: 65 72 76 65 72 0a 3b 3b 0a 28 64 65 66 69 6e 65 erver.;;.(define
11b0: 20 28 74 74 3a 73 74 61 72 74 2d 74 63 70 2d 73 (tt:start-tcp-s
11c0: 65 72 76 65 72 20 74 74 64 61 74 29 0a 20 20 28 erver ttdat). (
11d0: 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 20 74 setup-listener t
11e0: 74 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 tdat). (let* ((
11f0: 73 6f 63 6b 65 74 20 20 20 28 74 74 2d 73 72 76 socket (tt-srv
1200: 2d 73 6f 63 6b 65 74 20 74 74 64 61 74 29 29 0a -socket ttdat)).
1210: 09 20 28 68 61 6e 64 6c 65 72 20 20 28 74 74 2d . (handler (tt-
1220: 73 72 76 2d 68 61 6e 64 6c 65 72 20 20 20 20 74 srv-handler t
1230: 74 64 61 74 29 29 29 0a 20 20 20 20 28 28 6d 61 tdat))). ((ma
1240: 6b 65 2d 74 63 70 2d 73 65 72 76 65 72 20 73 6f ke-tcp-server so
1250: 63 6b 65 74 20 68 61 6e 64 6c 65 72 29 0a 20 20 cket handler).
1260: 20 20 20 23 74 20 3b 3b 20 79 65 73 2c 20 73 65 #t ;; yes, se
1270: 6e 64 20 65 72 72 6f 72 20 6d 65 73 73 61 67 65 nd error message
1280: 73 20 74 6f 20 73 74 64 2d 65 72 72 0a 20 20 20 s to std-err.
1290: 20 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))..(define (
12a0: 74 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 tt:keep-running
12b0: 74 74 64 61 74 20 64 62 66 69 6c 65 29 0a 20 20 ttdat dbfile).
12c0: 3b 3b 20 76 65 72 66 69 79 20 63 6f 6e 6e 20 66 ;; verfiy conn f
12d0: 6f 72 20 72 65 61 64 79 0a 20 20 3b 3b 20 6c 69 or ready. ;; li
12e0: 73 74 65 6e 65 72 20 73 6f 63 6b 65 74 20 68 61 stener socket ha
12f0: 73 20 62 65 65 6e 20 73 74 61 72 74 65 64 20 62 s been started b
1300: 79 20 74 68 69 73 20 73 74 61 67 65 0a 20 20 28 y this stage. (
1310: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
1320: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1330: 20 22 49 4e 46 4f 3a 20 47 6f 74 20 68 65 72 65 "INFO: Got here
1340: 21 21 21 21 22 29 29 0a 0a 3b 3b 20 3b 3b 20 67 !!!!"))..;; ;; g
1350: 69 76 65 6e 20 61 6e 20 61 6c 72 65 61 64 79 20 iven an already
1360: 73 65 74 20 75 70 20 75 63 6f 6e 6e 20 73 74 61 set up uconn sta
1370: 72 74 20 74 68 65 20 63 6d 64 2d 6c 6f 6f 70 0a rt the cmd-loop.
1380: 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 ;; ;;.;; (define
1390: 20 28 74 74 3a 63 6d 64 2d 6c 6f 6f 70 20 74 74 (tt:cmd-loop tt
13a0: 64 61 74 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 dat).;; (let*
13b0: 28 28 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 ((serv-listener
13c0: 28 2d 73 6f 63 6b 65 74 20 75 63 6f 6e 6e 29 29 (-socket uconn))
13d0: 0a 3b 3b 20 09 20 28 6c 69 73 74 65 6e 65 72 20 .;; . (listener
13e0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
13f0: 3b 3b 20 09 09 09 20 20 28 6c 65 74 20 6c 6f 6f ;; ... (let loo
1400: 70 20 28 28 73 74 61 74 65 20 27 73 74 61 72 74 p ((state 'start
1410: 29 29 0a 3b 3b 20 09 09 09 20 20 20 20 28 6c 65 )).;; ... (le
1420: 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 t-values (((inp
1430: 6f 75 70 29 28 74 63 70 2d 61 63 63 65 70 74 20 oup)(tcp-accept
1440: 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 29 29 29 serv-listener)))
1450: 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 3b 3b 20 .;; ... ;;
1460: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 73 65 (mutex-lock! *se
1470: 6e 64 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 44 4f nd-mutex*) ;; DO
1480: 45 53 4e 27 54 20 53 45 45 4d 20 54 4f 20 48 45 ESN'T SEEM TO HE
1490: 4c 50 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 28 LP.;; ... (
14a0: 6c 65 74 2a 20 28 28 72 64 61 74 20 20 28 64 65 let* ((rdat (de
14b0: 73 65 72 69 61 6c 69 7a 65 20 69 6e 70 29 29 20 serialize inp))
14c0: 3b 3b 20 27 28 6d 79 2d 68 6f 73 74 2d 70 6f 72 ;; '(my-host-por
14d0: 74 20 71 72 79 6b 65 79 20 63 6d 64 20 70 61 72 t qrykey cmd par
14e0: 61 6d 73 29 0a 3b 3b 20 09 09 09 09 20 20 20 20 ams).;; ....
14f0: 20 28 72 65 73 70 20 20 28 75 6c 65 78 2d 68 61 (resp (ulex-ha
1500: 6e 64 6c 65 72 20 75 63 6f 6e 6e 20 72 64 61 74 ndler uconn rdat
1510: 29 29 29 0a 3b 3b 20 09 09 09 09 28 73 65 72 69 ))).;; ....(seri
1520: 61 6c 69 7a 65 20 72 65 73 70 20 6f 75 70 29 0a alize resp oup).
1530: 3b 3b 20 09 09 09 09 28 63 6c 6f 73 65 2d 69 6e ;; ....(close-in
1540: 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 3b 3b put-port inp).;;
1550: 20 09 09 09 09 28 63 6c 6f 73 65 2d 6f 75 74 70 ....(close-outp
1560: 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 3b 3b 20 ut-port oup).;;
1570: 09 09 09 09 3b 3b 20 28 6d 75 74 65 78 2d 75 6e ....;; (mutex-un
1580: 6c 6f 63 6b 21 20 2a 73 65 6e 64 2d 6d 75 74 65 lock! *send-mute
1590: 78 2a 29 20 3b 3b 20 44 4f 45 53 4e 27 54 20 53 x*) ;; DOESN'T S
15a0: 45 45 4d 20 54 4f 20 48 45 4c 50 0a 3b 3b 20 09 EEM TO HELP.;; .
15b0: 09 09 09 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 ...).;; ...
15c0: 20 28 6c 6f 6f 70 20 73 74 61 74 65 29 29 29 29 (loop state))))
15d0: 29 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 73 74 61 )).;; ;; sta
15e0: 72 74 20 4e 20 6f 66 20 74 68 65 6d 0a 3b 3b 20 rt N of them.;;
15f0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
1600: 74 68 6e 75 6d 20 20 20 30 29 0a 3b 3b 20 09 20 thnum 0).;; .
1610: 20 20 20 20 20 20 28 74 68 72 65 61 64 73 20 27 (threads '
1620: 28 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 69 ())).;; (i
1630: 66 20 28 3c 20 74 68 6e 75 6d 20 31 30 30 29 0a f (< thnum 100).
1640: 3b 3b 20 09 20 20 28 6c 65 74 2a 20 28 28 74 68 ;; . (let* ((th
1650: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 6c 69 (make-thread li
1660: 73 74 65 6e 65 72 20 28 63 6f 6e 63 20 22 6c 69 stener (conc "li
1670: 73 74 65 6e 65 72 22 20 74 68 6e 75 6d 29 29 29 stener" thnum)))
1680: 29 0a 3b 3b 20 09 20 20 20 20 28 74 68 72 65 61 ).;; . (threa
1690: 64 2d 73 74 61 72 74 21 20 74 68 29 0a 3b 3b 20 d-start! th).;;
16a0: 09 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 74 68 . (loop (+ th
16b0: 6e 75 6d 20 31 29 0a 3b 3b 20 09 09 20 20 28 63 num 1).;; .. (c
16c0: 6f 6e 73 20 74 68 20 74 68 72 65 61 64 73 29 29 ons th threads))
16d0: 29 0a 3b 3b 20 09 20 20 28 6d 61 70 20 74 68 72 ).;; . (map thr
16e0: 65 61 64 2d 6a 6f 69 6e 21 20 74 68 72 65 61 64 ead-join! thread
16f0: 73 29 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 0a 3b s))))).;; .;; .;
1700: 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 77 ; .;; (define (w
1710: 61 69 74 2d 61 6e 64 2d 63 6c 6f 73 65 20 75 63 ait-and-close uc
1720: 6f 6e 6e 29 0a 3b 3b 20 20 20 28 74 68 72 65 61 onn).;; (threa
1730: 64 2d 6a 6f 69 6e 21 20 28 75 64 61 74 2d 63 6d d-join! (udat-cm
1740: 64 2d 74 68 72 65 61 64 20 75 63 6f 6e 6e 29 29 d-thread uconn))
1750: 0a 3b 3b 20 20 20 28 74 63 70 2d 63 6c 6f 73 65 .;; (tcp-close
1760: 20 28 75 64 61 74 2d 73 6f 63 6b 65 74 20 75 63 (udat-socket uc
1770: 6f 6e 6e 29 29 29 0a 3b 3b 20 0a 3b 3b 20 0a 0a onn))).;; .;; ..
1780: 28 64 65 66 69 6e 65 20 28 74 74 3a 73 68 75 74 (define (tt:shut
1790: 64 6f 77 6e 2d 73 65 72 76 65 72 20 74 74 64 61 down-server ttda
17a0: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 6c 65 t). (let* ((cle
17b0: 61 6e 70 72 6f 63 20 28 74 74 2d 73 72 76 2d 63 anproc (tt-srv-c
17c0: 6c 65 61 6e 75 70 2d 70 72 6f 63 20 74 74 64 61 leanup-proc ttda
17d0: 74 29 29 29 0a 20 20 20 20 28 69 66 20 63 6c 65 t))). (if cle
17e0: 61 6e 70 72 6f 63 20 28 63 6c 65 61 6e 70 72 6f anproc (cleanpro
17f0: 63 29 29 0a 20 20 20 20 28 74 63 70 2d 63 6c 6f c)). (tcp-clo
1800: 73 65 20 28 74 74 2d 73 72 76 2d 73 6f 63 6b 65 se (tt-srv-socke
1810: 74 20 74 74 64 61 74 29 29 20 3b 3b 20 63 6c 6f t ttdat)) ;; clo
1820: 73 65 20 75 70 20 70 6f 72 74 73 20 68 65 72 65 se up ports here
1830: 0a 20 20 20 20 29 29 0a 0a 3b 3b 20 28 64 65 66 . ))..;; (def
1840: 69 6e 65 20 28 77 61 69 74 2d 61 6e 64 2d 63 6c ine (wait-and-cl
1850: 6f 73 65 20 75 63 6f 6e 6e 29 0a 3b 3b 20 20 20 ose uconn).;;
1860: 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 28 74 (thread-join! (t
1870: 74 2d 73 72 76 2d 63 6d 64 2d 74 68 72 65 61 64 t-srv-cmd-thread
1880: 20 75 63 6f 6e 6e 29 29 0a 3b 3b 20 20 20 28 74 uconn)).;; (t
1890: 63 70 2d 63 6c 6f 73 65 20 28 74 74 2d 73 72 76 cp-close (tt-srv
18a0: 2d 73 6f 63 6b 65 74 20 75 63 6f 6e 6e 29 29 29 -socket uconn)))
18b0: 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 73 65 72 76 ..;; return serv
18c0: 69 64 0a 3b 3b 20 73 69 64 65 2d 65 66 66 65 63 id.;; side-effec
18d0: 74 73 3a 0a 3b 3b 20 20 20 74 74 64 61 74 2d 63 ts:.;; ttdat-c
18e0: 6c 65 61 6e 75 70 2d 70 72 6f 63 20 69 73 20 70 leanup-proc is p
18f0: 6f 70 75 6c 61 74 65 64 20 77 69 74 68 20 66 75 opulated with fu
1900: 6e 63 74 69 6f 6e 20 74 6f 20 72 65 6d 6f 76 65 nction to remove
1910: 20 74 68 65 20 73 65 72 76 65 72 69 6e 66 6f 20 the serverinfo
1920: 66 69 6c 65 0a 28 64 65 66 69 6e 65 20 28 74 74 file.(define (tt
1930: 3a 63 72 65 61 74 65 2d 73 65 72 76 65 72 2d 72 :create-server-r
1940: 65 67 69 73 74 72 61 74 69 6f 6e 2d 66 69 6c 65 egistration-file
1950: 20 74 74 64 61 74 20 64 62 66 6e 61 6d 65 29 0a ttdat dbfname).
1960: 20 20 28 6c 65 74 2a 20 28 28 61 72 65 61 70 61 (let* ((areapa
1970: 74 68 20 28 74 74 2d 61 72 65 61 70 61 74 68 20 th (tt-areapath
1980: 74 74 64 61 74 29 29 0a 09 20 28 73 65 72 76 64 ttdat)).. (servd
1990: 69 72 20 20 28 74 74 3a 67 65 74 2d 73 65 72 76 ir (tt:get-serv
19a0: 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 61 74 info-dir areapat
19b0: 68 29 29 0a 09 20 28 63 6f 6e 6e 20 20 20 20 20 h)).. (conn
19c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
19d0: 64 65 66 61 75 6c 74 20 28 74 74 2d 63 6f 6e 6e default (tt-conn
19e0: 73 20 74 74 64 61 74 29 20 64 62 66 6e 61 6d 65 s ttdat) dbfname
19f0: 20 23 66 29 29 29 0a 20 20 20 20 28 61 73 73 65 #f))). (asse
1a00: 72 74 20 63 6f 6e 6e 20 22 46 41 54 41 4c 3a 20 rt conn "FATAL:
1a10: 74 74 3a 63 72 65 61 74 65 2d 73 65 72 76 65 72 tt:create-server
1a20: 2d 72 65 67 69 73 74 72 61 74 69 6f 6e 2d 66 69 -registration-fi
1a30: 6c 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 6e le called with n
1a40: 6f 20 63 6f 6e 6e 2c 20 64 62 66 6e 61 6d 65 3d o conn, dbfname=
1a50: 22 64 62 66 6e 61 6d 65 29 0a 20 20 20 20 28 6c "dbfname). (l
1a60: 65 74 2a 20 28 28 68 6f 73 74 20 20 20 20 28 74 et* ((host (t
1a70: 74 2d 63 6f 6e 6e 2d 68 6f 73 74 20 63 6f 6e 6e t-conn-host conn
1a80: 29 29 0a 09 20 20 20 28 70 6f 72 74 20 20 20 20 )).. (port
1a90: 28 74 74 2d 63 6f 6e 6e 2d 70 6f 72 74 20 63 6f (tt-conn-port co
1aa0: 6e 6e 29 29 0a 09 20 20 20 28 73 65 72 76 69 6e nn)).. (servin
1ab0: 66 20 28 63 6f 6e 63 20 73 65 72 76 64 69 72 22 f (conc servdir"
1ac0: 2f 22 68 6f 73 74 22 3a 22 70 6f 72 74 22 2d 22 /"host":"port"-"
1ad0: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
1ae0: 2d 69 64 29 22 3a 22 64 62 66 6e 61 6d 65 29 29 -id)":"dbfname))
1af0: 0a 09 20 20 20 28 73 65 72 76 2d 69 64 20 28 74 .. (serv-id (t
1b00: 74 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 20 61 t:mk-signature a
1b10: 72 65 61 70 61 74 68 29 29 0a 09 20 20 20 28 63 reapath)).. (c
1b20: 6c 65 61 6e 2d 70 72 6f 63 20 28 6c 61 6d 62 64 lean-proc (lambd
1b30: 61 20 28 29 0a 09 09 09 20 28 64 65 6c 65 74 65 a ().... (delete
1b40: 2d 66 69 6c 65 2a 20 73 65 72 76 69 6e 66 29 29 -file* servinf))
1b50: 29 29 0a 20 20 20 20 20 20 28 74 74 2d 73 72 76 )). (tt-srv
1b60: 2d 63 6c 65 61 6e 75 70 2d 70 72 6f 63 2d 73 65 -cleanup-proc-se
1b70: 74 21 20 74 74 64 61 74 20 63 6c 65 61 6e 2d 70 t! ttdat clean-p
1b80: 72 6f 63 29 0a 20 20 20 20 20 20 28 77 69 74 68 roc). (with
1b90: 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 -output-to-file
1ba0: 73 65 72 76 69 6e 66 0a 09 28 6c 61 6d 62 64 61 servinf..(lambda
1bb0: 20 28 29 0a 09 20 20 28 70 72 69 6e 74 20 22 53 ().. (print "S
1bc0: 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 22 ERVER STARTED: "
1bd0: 68 6f 73 74 22 3a 22 70 6f 72 74 22 20 41 54 20 host":"port" AT
1be0: 22 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 "(current-second
1bf0: 73 29 22 20 73 65 72 76 65 72 2d 69 64 3a 20 22 s)" server-id: "
1c00: 73 65 72 76 2d 69 64 22 20 70 69 64 3a 20 22 28 serv-id" pid: "(
1c10: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
1c20: 69 64 29 22 20 64 62 66 6e 61 6d 65 3a 20 22 64 id)" dbfname: "d
1c30: 62 66 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 bfname))).
1c40: 73 65 72 76 2d 69 64 29 29 29 0a 0a 3b 3b 20 66 serv-id)))..;; f
1c50: 69 6e 64 20 76 61 6c 69 64 20 73 65 72 76 65 72 ind valid server
1c60: 0a 3b 3b 20 67 65 74 20 73 65 72 76 65 72 73 20 .;; get servers
1c70: 6c 69 73 74 65 64 2c 20 6c 61 73 74 20 70 61 72 listed, last par
1c80: 74 20 6f 66 20 6e 61 6d 65 20 6d 75 73 74 20 6d t of name must m
1c90: 61 74 63 68 20 3a 3c 64 62 66 6e 61 6d 65 3e 0a atch :<dbfname>.
1ca0: 3b 3b 20 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 ;; if more than
1cb0: 6f 6e 65 2c 20 77 61 69 74 20 6f 6e 65 20 73 65 one, wait one se
1cc0: 63 6f 6e 64 20 61 6e 64 20 6c 6f 6f 6b 20 61 67 cond and look ag
1cd0: 61 69 6e 0a 3b 3b 20 66 75 74 75 72 65 3a 20 70 ain.;; future: p
1ce0: 69 6e 67 20 6f 6c 64 65 73 74 2c 20 69 66 20 61 ing oldest, if a
1cf0: 6c 69 76 65 20 72 65 6d 6f 76 65 20 6f 74 68 65 live remove othe
1d00: 72 20 3a 3c 64 62 66 6e 61 6d 65 3e 20 66 69 6c r :<dbfname> fil
1d10: 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 es.;;.(define (t
1d20: 74 3a 66 69 6e 64 2d 73 65 72 76 65 72 20 74 74 t:find-server tt
1d30: 64 61 74 20 64 62 66 6e 61 6d 65 29 0a 20 20 28 dat dbfname). (
1d40: 6c 65 74 2a 20 28 28 61 72 65 61 70 61 74 68 20 let* ((areapath
1d50: 28 74 74 2d 61 72 65 61 70 61 74 68 20 74 74 64 (tt-areapath ttd
1d60: 61 74 29 29 0a 09 20 28 73 65 72 76 64 69 72 20 at)).. (servdir
1d70: 20 28 74 74 3a 67 65 74 2d 73 65 72 76 69 6e 66 (tt:get-servinf
1d80: 6f 2d 64 69 72 20 61 72 65 61 70 61 74 68 29 29 o-dir areapath))
1d90: 0a 09 20 28 73 66 69 6c 65 73 20 20 20 28 67 6c .. (sfiles (gl
1da0: 6f 62 20 28 63 6f 6e 63 20 73 65 72 76 64 69 72 ob (conc servdir
1db0: 22 2f 2a 3a 22 64 62 66 6e 61 6d 65 29 29 29 29 "/*:"dbfname))))
1dc0: 0a 20 20 20 20 73 66 69 6c 65 73 29 29 0a 0a 3b . sfiles))..;
1dd0: 3b 20 47 69 76 65 6e 20 61 6e 20 61 72 65 61 20 ; Given an area
1de0: 70 61 74 68 2c 20 20 73 74 61 72 74 20 61 20 73 path, start a s
1df0: 65 72 76 65 72 20 70 72 6f 63 65 73 73 20 20 20 erver process
1e00: 20 23 23 23 20 4e 4f 54 45 20 23 23 23 20 3e 20 ### NOTE ### >
1e10: 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b 20 69 66 file 2>&1 .;; if
1e20: 20 74 68 65 20 74 61 72 67 65 74 2d 68 6f 73 74 the target-host
1e30: 20 69 73 20 73 65 74 20 0a 3b 3b 20 74 72 79 20 is set .;; try
1e40: 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 68 61 74 20 running on that
1e50: 68 6f 73 74 0a 3b 3b 20 20 20 69 6e 63 69 64 65 host.;; incide
1e60: 6e 74 61 6c 3a 20 72 6f 74 61 74 65 20 6c 6f 67 ntal: rotate log
1e70: 73 20 69 6e 20 6c 6f 67 73 2f 20 64 69 72 2e 0a s in logs/ dir..
1e80: 3b 3b 0a 28 64 65 66 69 6e 65 20 20 28 74 74 3a ;;.(define (tt:
1e90: 73 65 72 76 65 72 2d 70 72 6f 63 65 73 73 2d 72 server-process-r
1ea0: 75 6e 20 61 72 65 61 70 61 74 68 20 74 65 73 74 un areapath test
1eb0: 73 75 69 74 65 20 6d 74 65 78 65 20 23 21 6b 65 suite mtexe #!ke
1ec0: 79 20 28 70 72 6f 66 69 6c 65 2d 6d 6f 64 65 20 y (profile-mode
1ed0: 22 22 29 29 20 3b 3b 20 61 72 65 61 70 61 74 68 "")) ;; areapath
1ee0: 20 69 73 20 2a 74 6f 70 70 61 74 68 2a 20 66 6f is *toppath* fo
1ef0: 72 20 61 20 67 69 76 65 6e 20 74 65 73 74 73 75 r a given testsu
1f00: 69 74 65 20 61 72 65 61 0a 20 20 28 6c 65 74 2a ite area. (let*
1f10: 20 28 28 6c 6f 67 66 69 6c 65 20 20 20 28 63 6f ((logfile (co
1f20: 6e 63 20 61 72 65 61 70 61 74 68 20 22 2f 6c 6f nc areapath "/lo
1f30: 67 73 2f 73 65 72 76 65 72 2e 6c 6f 67 22 29 29 gs/server.log"))
1f40: 20 3b 3b 20 2d 22 20 63 75 72 72 2d 70 69 64 20 ;; -" curr-pid
1f50: 22 2d 22 20 74 61 72 67 65 74 2d 68 6f 73 74 20 "-" target-host
1f60: 22 2e 6c 6f 67 22 29 29 0a 09 20 28 63 6d 64 6c ".log")).. (cmdl
1f70: 6e 20 20 20 20 20 28 63 6f 6e 63 0a 09 09 20 20 n (conc...
1f80: 20 20 20 6d 74 65 78 65 0a 09 09 20 20 20 20 20 mtexe...
1f90: 22 20 2d 73 65 72 76 65 72 20 2d 20 22 3b 3b 20 " -server - ";;
1fa0: 28 6f 72 20 74 61 72 67 65 74 2d 68 6f 73 74 20 (or target-host
1fb0: 22 2d 22 29 0a 09 09 20 20 20 20 20 22 20 2d 6d "-")... " -m
1fc0: 20 74 65 73 74 73 75 69 74 65 3a 22 20 74 65 73 testsuite:" tes
1fd0: 74 73 75 69 74 65 0a 09 09 20 20 20 20 20 22 20 tsuite... "
1fe0: 22 20 70 72 6f 66 69 6c 65 2d 6d 6f 64 65 0a 09 " profile-mode..
1ff0: 09 20 20 20 20 20 29 29 29 20 3b 3b 20 28 63 6f . ))) ;; (co
2000: 6e 63 20 22 20 3e 3e 20 22 20 6c 6f 67 66 69 6c nc " >> " logfil
2010: 65 20 22 20 32 3e 26 31 20 26 22 29 29 29 29 29 e " 2>&1 &")))))
2020: 0a 20 20 20 20 3b 3b 20 77 65 20 77 61 6e 74 20 . ;; we want
2030: 74 68 65 20 72 65 6d 6f 74 65 20 73 65 72 76 65 the remote serve
2040: 72 20 74 6f 20 73 74 61 72 74 20 69 6e 20 2a 74 r to start in *t
2050: 6f 70 70 61 74 68 2a 20 73 6f 20 70 75 73 68 20 oppath* so push
2060: 74 68 65 72 65 0a 20 20 20 20 28 70 75 73 68 2d there. (push-
2070: 64 69 72 65 63 74 6f 72 79 20 61 72 65 61 70 61 directory areapa
2080: 74 68 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 th). (debug:p
2090: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
20a0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
20b0: 20 54 72 79 69 6e 67 20 74 6f 20 73 74 61 72 74 Trying to start
20c0: 20 73 65 72 76 65 72 20 69 6e 20 74 63 70 20 6d server in tcp m
20d0: 6f 64 65 20 28 22 20 63 6d 64 6c 6e 20 22 29 20 ode (" cmdln ")
20e0: 2e 2e 2e 22 29 0a 20 20 20 20 28 64 65 62 75 67 ..."). (debug
20f0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
2100: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
2110: 4f 3a 20 73 74 61 72 74 69 6e 67 20 73 65 72 76 O: starting serv
2120: 65 72 20 61 74 20 22 20 28 63 6f 6d 6d 6f 6e 3a er at " (common:
2130: 68 75 6d 61 6e 2d 74 69 6d 65 29 29 0a 20 20 20 human-time)).
2140: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
2150: 6e 62 66 61 6b 65 20 22 20 63 6d 64 6c 6e 29 29 nbfake " cmdln))
2160: 0a 20 20 20 20 28 70 6f 70 2d 64 69 72 65 63 74 . (pop-direct
2170: 6f 72 79 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ory)))..;;======
2180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21c0: 0a 3b 3b 20 74 63 70 20 63 6f 6e 6e 65 63 74 69 .;; tcp connecti
21d0: 6f 6e 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d 3d on stuff.;;=====
21e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2220: 3d 0a 0a 3b 3b 20 63 72 65 61 74 65 20 61 20 74 =..;; create a t
2230: 63 70 20 6c 69 73 74 65 6e 65 72 20 61 6e 64 20 cp listener and
2240: 72 65 74 75 72 6e 20 61 20 70 6f 70 75 6c 61 74 return a populat
2250: 65 64 20 75 64 61 74 20 73 74 72 75 63 74 20 77 ed udat struct w
2260: 69 74 68 0a 3b 3b 20 6d 79 20 70 6f 72 74 2c 20 ith.;; my port,
2270: 61 64 64 72 65 73 73 2c 20 68 6f 73 74 6e 61 6d address, hostnam
2280: 65 2c 20 70 69 64 20 65 74 63 2e 0a 3b 3b 20 72 e, pid etc..;; r
2290: 65 74 75 72 6e 20 23 66 20 69 66 20 66 61 69 6c eturn #f if fail
22a0: 20 74 6f 20 66 69 6e 64 20 61 20 70 6f 72 74 20 to find a port
22b0: 74 6f 20 61 6c 6c 6f 63 61 74 65 2e 0a 3b 3b 0a to allocate..;;.
22c0: 3b 3b 20 20 69 66 20 75 64 61 74 61 2d 69 6e 20 ;; if udata-in
22d0: 69 73 20 23 66 20 63 72 65 61 74 65 20 74 68 65 is #f create the
22e0: 20 72 65 63 6f 72 64 0a 3b 3b 20 20 69 66 20 74 record.;; if t
22f0: 68 65 72 65 20 69 73 20 61 6c 72 65 61 64 79 20 here is already
2300: 61 20 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 a serv-listener
2310: 72 65 74 75 72 6e 20 74 68 65 20 75 64 61 74 61 return the udata
2320: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 74 .;;.(define (set
2330: 75 70 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e up-listener ucon
2340: 6e 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 70 6f n #!optional (po
2350: 72 74 20 34 32 34 32 29 29 0a 20 20 28 61 73 73 rt 4242)). (ass
2360: 65 72 74 20 28 74 74 2d 73 72 76 3f 20 75 63 6f ert (tt-srv? uco
2370: 6e 6e 29 20 22 46 41 54 41 4c 3a 20 73 65 74 75 nn) "FATAL: setu
2380: 70 2d 6c 69 73 74 65 6e 65 72 20 63 61 6c 6c 65 p-listener calle
2390: 64 20 77 69 74 68 20 77 72 6f 6e 67 20 73 74 72 d with wrong str
23a0: 75 63 74 20 22 75 63 6f 6e 6e 29 0a 20 20 28 68 uct "uconn). (h
23b0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
23c0: 0a 20 20 20 65 78 6e 0a 20 20 20 28 69 66 20 28 . exn. (if (
23d0: 3c 20 70 6f 72 74 20 36 35 35 33 35 29 0a 20 20 < port 65535).
23e0: 20 20 20 20 20 28 73 65 74 75 70 2d 6c 69 73 74 (setup-list
23f0: 65 6e 65 72 20 75 63 6f 6e 6e 20 28 2b 20 70 6f ener uconn (+ po
2400: 72 74 20 31 29 29 0a 20 20 20 20 20 20 20 23 66 rt 1)). #f
2410: 29 0a 20 20 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 ). (connect-li
2420: 73 74 65 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 stener uconn por
2430: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 t)))..(define (c
2440: 6f 6e 6e 65 63 74 2d 6c 69 73 74 65 6e 65 72 20 onnect-listener
2450: 75 63 6f 6e 6e 20 70 6f 72 74 29 0a 20 20 3b 3b uconn port). ;;
2460: 20 28 74 63 70 2d 6c 69 73 74 65 6e 65 72 2d 73 (tcp-listener-s
2470: 6f 63 6b 65 74 20 4c 49 53 54 45 4e 45 52 29 28 ocket LISTENER)(
2480: 73 6f 63 6b 65 74 2d 6e 61 6d 65 20 73 6f 29 0a socket-name so).
2490: 20 20 3b 3b 20 73 6f 63 6b 61 64 64 72 2d 61 64 ;; sockaddr-ad
24a0: 64 72 65 73 73 2c 20 73 6f 63 6b 61 64 64 72 2d dress, sockaddr-
24b0: 70 6f 72 74 2c 20 73 6f 63 6b 61 64 64 72 2d 3e port, sockaddr->
24c0: 73 74 72 69 6e 67 0a 20 20 28 6c 65 74 2a 20 28 string. (let* (
24d0: 28 74 6c 73 6e 20 28 74 63 70 2d 6c 69 73 74 65 (tlsn (tcp-liste
24e0: 6e 20 70 6f 72 74 20 31 30 30 30 20 23 66 29 29 n port 1000 #f))
24f0: 20 3b 3b 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 ;; (tcp-listen
2500: 54 43 50 50 4f 52 54 20 5b 42 41 43 4b 4c 4f 47 TCPPORT [BACKLOG
2510: 20 5b 48 4f 53 54 5d 5d 29 0a 09 20 28 61 64 64 [HOST]]).. (add
2520: 72 20 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 r (get-my-best-a
2530: 64 64 72 65 73 73 29 29 29 20 3b 3b 20 28 68 6f ddress))) ;; (ho
2540: 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 stinfo-addresses
2550: 20 28 68 6f 73 74 2d 69 6e 66 6f 72 6d 61 74 69 (host-informati
2560: 6f 6e 20 28 63 75 72 72 65 6e 74 2d 68 6f 73 74 on (current-host
2570: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 74 74 2d name))). (tt-
2580: 73 72 76 2d 70 6f 72 74 2d 73 65 74 21 20 20 20 srv-port-set!
2590: 20 20 20 75 63 6f 6e 6e 20 70 6f 72 74 29 0a 20 uconn port).
25a0: 20 20 20 28 74 74 2d 73 72 76 2d 68 6f 73 74 2d (tt-srv-host-
25b0: 70 6f 72 74 2d 73 65 74 21 20 75 63 6f 6e 6e 20 port-set! uconn
25c0: 28 63 6f 6e 63 20 61 64 64 72 22 3a 22 70 6f 72 (conc addr":"por
25d0: 74 29 29 0a 20 20 20 20 28 74 74 2d 73 72 76 2d t)). (tt-srv-
25e0: 73 6f 63 6b 65 74 2d 73 65 74 21 20 20 20 20 75 socket-set! u
25f0: 63 6f 6e 6e 20 74 6c 73 6e 29 0a 20 20 20 20 75 conn tlsn). u
2600: 63 6f 6e 6e 29 29 0a 0a 0a 0a 3b 3b 3d 3d 3d 3d conn))....;;====
2610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2650: 3d 3d 0a 3b 3b 20 75 74 69 6c 73 0a 3b 3b 3d 3d ==.;; utils.;;==
2660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26a0: 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 72 61 74 ====..;; Generat
26b0: 65 20 61 20 75 6e 69 71 75 65 20 73 69 67 6e 61 e a unique signa
26c0: 74 75 72 65 20 66 6f 72 20 74 68 69 73 20 73 65 ture for this se
26d0: 72 76 65 72 0a 28 64 65 66 69 6e 65 20 28 74 74 rver.(define (tt
26e0: 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 20 61 72 :mk-signature ar
26f0: 65 61 70 61 74 68 29 0a 20 20 28 6d 65 73 73 61 eapath). (messa
2700: 67 65 2d 64 69 67 65 73 74 2d 73 74 72 69 6e 67 ge-digest-string
2710: 20 28 6d 64 35 2d 70 72 69 6d 69 74 69 76 65 29 (md5-primitive)
2720: 20 0a 09 09 09 20 28 77 69 74 68 2d 6f 75 74 70 .... (with-outp
2730: 75 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 09 09 09 ut-to-string....
2740: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
2750: 09 20 20 20 20 20 28 77 72 69 74 65 20 28 6c 69 . (write (li
2760: 73 74 20 61 72 65 61 70 61 74 68 0a 20 20 20 20 st areapath.
2770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2790: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 70 (current-p
27a0: 72 6f 63 65 73 73 2d 69 64 29 0a 09 09 09 09 09 rocess-id)......
27b0: 20 20 28 61 72 67 76 29 29 29 29 29 29 29 0a 0a (argv)))))))..
27c0: 0a 28 64 65 66 69 6e 65 20 28 74 74 3a 67 65 74 .(define (tt:get
27d0: 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 -best-guess-addr
27e0: 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 ess hostname).
27f0: 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a (let ((res #f)).
2800: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
2810: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 64 72 (lambda (adr
2820: 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f ). (if (no
2830: 74 20 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 t (eq? (u8vector
2840: 2d 72 65 66 20 61 64 72 20 30 29 20 31 32 37 29 -ref adr 0) 127)
2850: 29 0a 09 20 20 20 28 73 65 74 21 20 72 65 73 20 ).. (set! res
2860: 61 64 72 29 29 29 0a 20 20 20 20 20 3b 3b 20 4e adr))). ;; N
2870: 4f 54 45 3a 20 54 68 69 73 20 63 61 6e 20 66 61 OTE: This can fa
2880: 69 6c 20 77 68 65 6e 20 74 68 65 72 65 20 69 73 il when there is
2890: 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 6f 66 20 74 no mention of t
28a0: 68 65 20 68 6f 73 74 20 69 6e 20 2f 65 74 63 2f he host in /etc/
28b0: 68 6f 73 74 73 2e 20 46 49 58 4d 45 0a 20 20 20 hosts. FIXME.
28c0: 20 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 (vector->list
28d0: 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 (hostinfo-addres
28e0: 73 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 ses (hostname->h
28f0: 6f 73 74 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 ostinfo hostname
2900: 29 29 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 )))). (string
2910: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 -intersperse .
2920: 20 20 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e (map number->
2930: 73 74 72 69 6e 67 0a 09 20 20 28 75 38 76 65 63 string.. (u8vec
2940: 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 20 20 28 69 tor->list.. (i
2950: 66 20 72 65 73 20 72 65 73 20 28 68 6f 73 74 6e f res res (hostn
2960: 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 ame->ip hostname
2970: 29 29 29 29 20 22 2e 22 29 29 29 0a 0a 28 64 65 )))) ".")))..(de
2980: 66 69 6e 65 20 28 74 74 3a 67 65 74 2d 73 65 72 fine (tt:get-ser
2990: 76 69 6e 66 6f 2d 64 69 72 20 61 72 65 61 70 61 vinfo-dir areapa
29a0: 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 70 th). (let* ((sp
29b0: 61 74 68 20 28 63 6f 6e 63 20 61 72 65 61 70 61 ath (conc areapa
29c0: 74 68 22 2f 2e 73 65 72 76 69 6e 66 6f 22 29 29 th"/.servinfo"))
29d0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
29e0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 70 61 file-exists? spa
29f0: 74 68 29 29 0a 09 28 63 72 65 61 74 65 2d 64 69 th))..(create-di
2a00: 72 65 63 74 6f 72 79 20 73 70 61 74 68 20 23 74 rectory spath #t
2a10: 29 29 0a 20 20 20 20 73 70 61 74 68 29 29 0a 0a )). spath))..
2a20: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
2a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a60: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 6e 65 74 77 ========.;; netw
2a70: 6f 72 6b 20 75 74 69 6c 69 74 69 65 73 0a 3b 3b ork utilities.;;
2a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ac0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 4f 54 45 3a ======..;; NOTE:
2ad0: 20 4c 6f 6f 6b 20 61 74 20 61 64 64 72 65 73 73 Look at address
2ae0: 2d 69 6e 66 6f 20 65 67 67 20 61 73 20 61 6c 74 -info egg as alt
2af0: 65 72 6e 61 74 69 76 65 20 74 6f 20 73 6f 6d 65 ernative to some
2b00: 20 6f 66 20 74 68 69 73 0a 0a 28 64 65 66 69 6e of this..(defin
2b10: 65 20 28 72 61 74 65 2d 69 70 20 69 70 61 64 64 e (rate-ip ipadd
2b20: 72 29 0a 20 20 28 72 65 67 65 78 2d 63 61 73 65 r). (regex-case
2b30: 20 69 70 61 64 64 72 0a 20 20 20 20 28 20 22 5e ipaddr. ( "^
2b40: 31 32 37 5c 5c 2e 2e 2a 22 20 5f 20 30 20 29 0a 127\\..*" _ 0 ).
2b50: 20 20 20 20 28 20 22 5e 28 31 30 5c 5c 2e 30 7c ( "^(10\\.0|
2b60: 31 39 32 5c 5c 2e 31 36 38 29 5c 5c 2e 2e 2a 22 192\\.168)\\..*"
2b70: 20 5f 20 31 20 29 0a 20 20 20 20 28 20 65 6c 73 _ 1 ). ( els
2b80: 65 20 32 20 29 20 29 29 0a 0a 3b 3b 20 43 68 61 e 2 ) ))..;; Cha
2b90: 6e 67 65 20 74 68 69 73 20 74 6f 20 62 69 61 73 nge this to bias
2ba0: 20 66 6f 72 20 61 64 64 72 65 73 73 65 73 20 77 for addresses w
2bb0: 69 74 68 20 61 20 72 65 61 73 6f 6e 61 62 6c 65 ith a reasonable
2bc0: 20 62 72 6f 61 64 63 61 73 74 20 76 61 6c 75 65 broadcast value
2bd0: 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 69 70 ?.;;.(define (ip
2be0: 2d 70 72 65 66 2d 6c 65 73 73 3f 20 61 20 62 29 -pref-less? a b)
2bf0: 0a 20 20 28 3e 20 28 72 61 74 65 2d 69 70 20 61 . (> (rate-ip a
2c00: 29 20 28 72 61 74 65 2d 69 70 20 62 29 29 29 0a ) (rate-ip b))).
2c10: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6d 79 .(define (get-my
2c20: 2d 62 65 73 74 2d 61 64 64 72 65 73 73 29 0a 20 -best-address).
2c30: 20 28 6c 65 74 20 28 28 61 6c 6c 2d 6d 79 2d 61 (let ((all-my-a
2c40: 64 64 72 65 73 73 65 73 20 28 67 65 74 2d 61 6c ddresses (get-al
2c50: 6c 2d 69 70 73 29 29 29 0a 20 20 20 20 28 63 6f l-ips))). (co
2c60: 6e 64 0a 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 nd. ((null?
2c70: 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 all-my-addresses
2c80: 29 0a 20 20 20 20 20 20 28 67 65 74 2d 68 6f 73 ). (get-hos
2c90: 74 2d 6e 61 6d 65 29 29 20 20 20 20 20 20 20 20 t-name))
2ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cc0: 20 20 3b 3b 20 6e 6f 20 69 6e 74 65 72 66 61 63 ;; no interfac
2cd0: 65 73 3f 0a 20 20 20 20 20 28 28 65 71 3f 20 28 es?. ((eq? (
2ce0: 6c 65 6e 67 74 68 20 61 6c 6c 2d 6d 79 2d 61 64 length all-my-ad
2cf0: 64 72 65 73 73 65 73 29 20 31 29 0a 20 20 20 20 dresses) 1).
2d00: 20 20 28 63 61 72 20 61 6c 6c 2d 6d 79 2d 61 64 (car all-my-ad
2d10: 64 72 65 73 73 65 73 29 29 20 20 20 20 20 20 20 dresses))
2d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
2d30: 3b 20 6f 6e 6c 79 20 6f 6e 65 20 74 6f 20 63 68 ; only one to ch
2d40: 6f 6f 73 65 20 66 72 6f 6d 2c 20 6a 75 73 74 20 oose from, just
2d50: 67 6f 20 77 69 74 68 20 69 74 0a 20 20 20 20 20 go with it.
2d60: 28 65 6c 73 65 0a 20 20 20 20 20 20 28 63 61 72 (else. (car
2d70: 20 28 73 6f 72 74 20 61 6c 6c 2d 6d 79 2d 61 64 (sort all-my-ad
2d80: 64 72 65 73 73 65 73 20 69 70 2d 70 72 65 66 2d dresses ip-pref-
2d90: 6c 65 73 73 3f 29 29 29 29 29 29 0a 0a 28 64 65 less?))))))..(de
2da0: 66 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 69 70 fine (get-all-ip
2db0: 73 2d 73 6f 72 74 65 64 29 0a 20 20 28 73 6f 72 s-sorted). (sor
2dc0: 74 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 20 t (get-all-ips)
2dd0: 69 70 2d 70 72 65 66 2d 6c 65 73 73 3f 29 29 0a ip-pref-less?)).
2de0: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 61 6c .(define (get-al
2df0: 6c 2d 69 70 73 29 0a 20 20 28 6d 61 70 20 61 64 l-ips). (map ad
2e00: 64 72 65 73 73 2d 69 6e 66 6f 2d 68 6f 73 74 0a dress-info-host.
2e10: 20 20 20 20 20 20 20 28 66 69 6c 74 65 72 20 28 (filter (
2e20: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 20 28 65 lambda (x)... (e
2e30: 71 75 61 6c 3f 20 28 61 64 64 72 65 73 73 2d 69 qual? (address-i
2e40: 6e 66 6f 2d 74 79 70 65 20 78 29 20 22 74 63 70 nfo-type x) "tcp
2e50: 22 29 29 0a 09 20 20 20 20 20 20 20 28 61 64 64 ")).. (add
2e60: 72 65 73 73 2d 69 6e 66 6f 73 20 28 67 65 74 2d ress-infos (get-
2e70: 68 6f 73 74 2d 6e 61 6d 65 29 29 29 29 29 0a 0a host-name)))))..
2e80: 29 0a ).