Artifact
c344faad69796fac004cd0367fdefc5cb341d897:
0000: 3b 3b 20 75 6c 65 78 3a 20 44 69 73 74 72 69 62 ;; ulex: Distrib
0010: 75 74 65 64 20 73 71 6c 69 74 65 33 20 64 62 0a uted sqlite3 db.
0020: 3b 3b 3b 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 ;;;.;; Copyright
0030: 20 28 43 29 20 32 30 31 38 20 4d 61 74 74 20 57 (C) 2018 Matt W
0040: 65 6c 6c 61 6e 64 0a 3b 3b 20 52 65 64 69 73 74 elland.;; Redist
0050: 72 69 62 75 74 69 6f 6e 20 61 6e 64 20 75 73 65 ribution and use
0060: 20 69 6e 20 73 6f 75 72 63 65 20 61 6e 64 20 62 in source and b
0070: 69 6e 61 72 79 20 66 6f 72 6d 73 2c 20 77 69 74 inary forms, wit
0080: 68 20 6f 72 20 77 69 74 68 6f 75 74 0a 3b 3b 20 h or without.;;
0090: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2c 20 69 73 modification, is
00a0: 20 70 65 72 6d 69 74 74 65 64 2e 0a 3b 3b 0a 3b permitted..;;.;
00b0: 3b 20 54 48 49 53 20 53 4f 46 54 57 41 52 45 20 ; THIS SOFTWARE
00c0: 49 53 20 50 52 4f 56 49 44 45 44 20 42 59 20 54 IS PROVIDED BY T
00d0: 48 45 20 41 55 54 48 4f 52 20 60 60 41 53 20 49 HE AUTHOR ``AS I
00e0: 53 27 27 20 41 4e 44 20 41 4e 59 20 45 58 50 52 S'' AND ANY EXPR
00f0: 45 53 53 0a 3b 3b 20 4f 52 20 49 4d 50 4c 49 45 ESS.;; OR IMPLIE
0100: 44 20 57 41 52 52 41 4e 54 49 45 53 2c 20 49 4e D WARRANTIES, IN
0110: 43 4c 55 44 49 4e 47 2c 20 42 55 54 20 4e 4f 54 CLUDING, BUT NOT
0120: 20 4c 49 4d 49 54 45 44 20 54 4f 2c 20 54 48 45 LIMITED TO, THE
0130: 20 49 4d 50 4c 49 45 44 0a 3b 3b 20 57 41 52 52 IMPLIED.;; WARR
0140: 41 4e 54 49 45 53 20 4f 46 20 4d 45 52 43 48 41 ANTIES OF MERCHA
0150: 4e 54 41 42 49 4c 49 54 59 20 41 4e 44 20 46 49 NTABILITY AND FI
0160: 54 4e 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 TNESS FOR A PART
0170: 49 43 55 4c 41 52 20 50 55 52 50 4f 53 45 0a 3b ICULAR PURPOSE.;
0180: 3b 20 41 52 45 20 44 49 53 43 4c 41 49 4d 45 44 ; ARE DISCLAIMED
0190: 2e 20 20 49 4e 20 4e 4f 20 45 56 45 4e 54 20 53 . IN NO EVENT S
01a0: 48 41 4c 4c 20 54 48 45 20 41 55 54 48 4f 52 20 HALL THE AUTHOR
01b0: 4f 52 20 43 4f 4e 54 52 49 42 55 54 4f 52 53 20 OR CONTRIBUTORS
01c0: 42 45 0a 3b 3b 20 4c 49 41 42 4c 45 20 46 4f 52 BE.;; LIABLE FOR
01d0: 20 41 4e 59 20 44 49 52 45 43 54 2c 20 49 4e 44 ANY DIRECT, IND
01e0: 49 52 45 43 54 2c 20 49 4e 43 49 44 45 4e 54 41 IRECT, INCIDENTA
01f0: 4c 2c 20 53 50 45 43 49 41 4c 2c 20 45 58 45 4d L, SPECIAL, EXEM
0200: 50 4c 41 52 59 2c 20 4f 52 0a 3b 3b 20 43 4f 4e PLARY, OR.;; CON
0210: 53 45 51 55 45 4e 54 49 41 4c 20 44 41 4d 41 47 SEQUENTIAL DAMAG
0220: 45 53 20 28 49 4e 43 4c 55 44 49 4e 47 2c 20 42 ES (INCLUDING, B
0230: 55 54 20 4e 4f 54 20 4c 49 4d 49 54 45 44 20 54 UT NOT LIMITED T
0240: 4f 2c 20 50 52 4f 43 55 52 45 4d 45 4e 54 0a 3b O, PROCUREMENT.;
0250: 3b 20 4f 46 20 53 55 42 53 54 49 54 55 54 45 20 ; OF SUBSTITUTE
0260: 47 4f 4f 44 53 20 4f 52 20 53 45 52 56 49 43 45 GOODS OR SERVICE
0270: 53 3b 20 4c 4f 53 53 20 4f 46 20 55 53 45 2c 20 S; LOSS OF USE,
0280: 44 41 54 41 2c 20 4f 52 20 50 52 4f 46 49 54 53 DATA, OR PROFITS
0290: 3b 20 4f 52 0a 3b 3b 20 42 55 53 49 4e 45 53 53 ; OR.;; BUSINESS
02a0: 20 49 4e 54 45 52 52 55 50 54 49 4f 4e 29 20 48 INTERRUPTION) H
02b0: 4f 57 45 56 45 52 20 43 41 55 53 45 44 20 41 4e OWEVER CAUSED AN
02c0: 44 20 4f 4e 20 41 4e 59 20 54 48 45 4f 52 59 20 D ON ANY THEORY
02d0: 4f 46 0a 3b 3b 20 4c 49 41 42 49 4c 49 54 59 2c OF.;; LIABILITY,
02e0: 20 57 48 45 54 48 45 52 20 49 4e 20 43 4f 4e 54 WHETHER IN CONT
02f0: 52 41 43 54 2c 20 53 54 52 49 43 54 20 4c 49 41 RACT, STRICT LIA
0300: 42 49 4c 49 54 59 2c 20 4f 52 20 54 4f 52 54 0a BILITY, OR TORT.
0310: 3b 3b 20 28 49 4e 43 4c 55 44 49 4e 47 20 4e 45 ;; (INCLUDING NE
0320: 47 4c 49 47 45 4e 43 45 20 4f 52 20 4f 54 48 45 GLIGENCE OR OTHE
0330: 52 57 49 53 45 29 20 41 52 49 53 49 4e 47 20 49 RWISE) ARISING I
0340: 4e 20 41 4e 59 20 57 41 59 20 4f 55 54 20 4f 46 N ANY WAY OUT OF
0350: 20 54 48 45 0a 3b 3b 20 55 53 45 20 4f 46 20 54 THE.;; USE OF T
0360: 48 49 53 20 53 4f 46 54 57 41 52 45 2c 20 45 56 HIS SOFTWARE, EV
0370: 45 4e 20 49 46 20 41 44 56 49 53 45 44 20 4f 46 EN IF ADVISED OF
0380: 20 54 48 45 20 50 4f 53 53 49 42 49 4c 49 54 59 THE POSSIBILITY
0390: 20 4f 46 20 53 55 43 48 0a 3b 3b 20 44 41 4d 41 OF SUCH.;; DAMA
03a0: 47 45 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d GE...;;=========
03b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
03f0: 20 41 42 4f 55 54 3a 0a 3b 3b 20 20 20 53 65 65 ABOUT:.;; See
0400: 20 52 45 41 44 4d 45 20 69 6e 20 74 68 65 20 64 README in the d
0410: 69 73 74 72 69 62 75 74 69 6f 6e 20 61 74 20 68 istribution at h
0420: 74 74 70 73 3a 2f 2f 77 77 77 2e 6b 69 61 74 6f ttps://www.kiato
0430: 61 2e 63 6f 6d 2f 66 6f 73 73 69 6c 73 2f 75 6c a.com/fossils/ul
0440: 65 78 0a 3b 3b 20 4e 4f 54 45 53 3a 0a 3b 3b 20 ex.;; NOTES:.;;
0450: 20 20 57 68 79 20 73 71 6c 2d 64 65 2d 6c 69 74 Why sql-de-lit
0460: 65 20 61 6e 64 20 6e 6f 74 20 73 61 79 2c 20 64 e and not say, d
0470: 62 69 3f 20 20 2d 20 70 65 72 66 6f 72 6d 61 6e bi? - performan
0480: 63 65 20 6d 6f 73 74 6c 79 2c 20 74 68 65 6e 20 ce mostly, then
0490: 73 69 6d 70 6c 69 63 69 74 79 2e 0a 3b 3b 0a 3b simplicity..;;.;
04a0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04e0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 20 6d 61 =======..(use ma
04f0: 69 6c 62 6f 78 29 0a 0a 28 6d 6f 64 75 6c 65 20 ilbox)..(module
0500: 75 6c 65 78 0a 20 2a 0a 0a 28 69 6d 70 6f 72 74 ulex. *..(import
0510: 20 73 63 68 65 6d 65 0a 0a 09 63 68 69 63 6b 65 scheme...chicke
0520: 6e 0a 09 64 61 74 61 2d 73 74 72 75 63 74 75 72 n..data-structur
0530: 65 73 0a 09 66 69 6c 65 73 0a 09 66 6f 72 65 69 es..files..forei
0540: 67 6e 0a 09 68 6f 73 74 69 6e 66 6f 0a 09 6d 61 gn..hostinfo..ma
0550: 69 6c 62 6f 78 0a 09 6d 61 74 63 68 61 62 6c 65 ilbox..matchable
0560: 0a 09 70 6f 72 74 73 20 65 78 74 72 61 73 0a 09 ..ports extras..
0570: 70 6f 73 69 78 0a 09 72 65 67 65 78 0a 09 72 65 posix..regex..re
0580: 67 65 78 2d 63 61 73 65 0a 09 73 72 66 69 2d 31 gex-case..srfi-1
0590: 0a 09 73 72 66 69 2d 31 38 0a 09 73 72 66 69 2d ..srfi-18..srfi-
05a0: 34 0a 09 73 72 66 69 2d 36 39 0a 09 74 63 70 36 4..srfi-69..tcp6
05b0: 0a 09 74 79 70 65 64 2d 72 65 63 6f 72 64 73 0a ..typed-records.
05c0: 09 29 0a 0a 3b 3b 20 75 64 61 74 20 73 74 72 75 .)..;; udat stru
05d0: 63 74 2c 20 75 73 65 64 20 62 79 20 62 6f 74 68 ct, used by both
05e0: 20 63 61 6c 6c 65 72 20 61 6e 64 20 63 61 6c 6c caller and call
05f0: 65 65 0a 3b 3b 20 69 6e 73 74 61 6e 74 69 61 74 ee.;; instantiat
0600: 65 64 20 61 73 20 75 63 6f 6e 6e 20 62 79 20 63 ed as uconn by c
0610: 6f 6e 76 65 6e 74 69 6f 6e 0a 3b 3b 0a 28 64 65 onvention.;;.(de
0620: 66 73 74 72 75 63 74 20 75 64 61 74 0a 20 20 3b fstruct udat. ;
0630: 3b 20 74 68 65 20 6c 69 73 74 65 6e 65 72 20 73 ; the listener s
0640: 69 64 65 0a 20 20 28 68 6f 73 74 2d 70 6f 72 74 ide. (host-port
0650: 20 23 66 29 0a 20 20 28 73 6f 63 6b 65 74 20 23 #f). (socket #
0660: 66 29 0a 20 20 3b 3b 20 74 68 65 20 70 65 65 72 f). ;; the peer
0670: 73 0a 20 20 28 70 65 65 72 73 20 20 28 6d 61 6b s. (peers (mak
0680: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
0690: 3b 20 68 6f 73 74 3a 70 6f 72 74 2d 3e 70 65 65 ; host:port->pee
06a0: 72 0a 20 20 3b 3b 20 77 6f 72 6b 20 68 61 6e 64 r. ;; work hand
06b0: 6c 69 6e 67 0a 20 20 28 77 6f 72 6b 2d 71 75 65 ling. (work-que
06c0: 75 65 20 28 6d 61 6b 65 2d 71 75 65 75 65 29 29 ue (make-queue))
06d0: 0a 20 20 28 63 6e 75 6d 20 20 20 20 20 20 20 30 . (cnum 0
06e0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ) ;;
06f0: 20 63 6f 6f 6b 69 65 20 6e 75 6d 62 65 72 0a 20 cookie number.
0700: 20 28 6d 62 6f 78 65 73 20 20 20 20 20 28 6d 61 (mboxes (ma
0710: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
0720: 20 20 29 0a 0a 3b 3b 20 73 74 72 75 63 74 20 66 )..;; struct f
0730: 6f 72 20 6b 65 65 70 69 6e 67 20 74 72 61 63 6b or keeping track
0740: 20 6f 66 20 6f 74 68 65 72 73 20 77 65 20 61 72 of others we ar
0750: 65 20 74 61 6c 6b 69 6e 67 20 74 6f 0a 3b 3b 0a e talking to.;;.
0760: 28 64 65 66 73 74 72 75 63 74 20 70 64 61 74 0a (defstruct pdat.
0770: 20 20 28 68 6f 73 74 2d 70 6f 72 74 20 20 23 66 (host-port #f
0780: 29 0a 20 20 28 63 6f 6e 6e 73 20 20 20 20 20 20 ). (conns
0790: 27 28 29 29 20 3b 3b 20 6c 69 73 74 20 6f 66 20 '()) ;; list of
07a0: 70 63 6f 6e 20 73 74 72 75 63 74 73 2c 20 70 6f pcon structs, po
07b0: 70 20 6f 6e 65 20 6f 66 66 20 77 68 65 6e 20 63 p one off when c
07c0: 61 6c 6c 69 6e 67 20 74 68 65 20 70 65 65 72 0a alling the peer.
07d0: 20 20 29 0a 0a 3b 3b 20 73 74 72 75 63 74 20 66 )..;; struct f
07e0: 6f 72 20 70 65 65 72 20 63 6f 6e 6e 65 63 74 69 or peer connecti
07f0: 6f 6e 73 2c 20 6b 65 65 70 20 74 72 61 63 6b 20 ons, keep track
0800: 6f 66 20 65 78 70 69 72 61 74 69 6f 6e 20 65 74 of expiration et
0810: 63 2e 0a 3b 3b 0a 28 64 65 66 73 74 72 75 63 74 c..;;.(defstruct
0820: 20 70 63 6f 6e 0a 20 20 28 69 6e 70 20 23 66 29 pcon. (inp #f)
0830: 0a 20 20 28 6f 75 70 20 23 66 29 0a 20 20 28 65 . (oup #f). (e
0840: 78 70 20 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 xp (+ (current-s
0850: 65 63 6f 6e 64 73 29 20 35 39 29 29 20 3b 3b 20 econds) 59)) ;;
0860: 65 78 70 69 72 65 73 20 61 74 20 74 68 69 73 20 expires at this
0870: 74 69 6d 65 2c 20 73 65 74 20 74 6f 20 28 2b 20 time, set to (+
0880: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
0890: 29 20 35 39 29 0a 20 20 28 6c 69 66 65 74 69 6d ) 59). (lifetim
08a0: 65 20 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 e (+ (current-se
08b0: 63 6f 6e 64 73 29 20 36 30 30 29 29 20 3b 3b 20 conds) 600)) ;;
08c0: 74 68 72 6f 77 20 61 77 61 79 20 61 6e 64 20 63 throw away and c
08d0: 72 65 61 74 65 20 6e 65 77 20 61 66 74 65 72 20 reate new after
08e0: 66 69 76 65 20 6d 69 6e 75 74 65 73 0a 20 20 29 five minutes. )
08f0: 0a 0a 3b 3b 20 73 65 6e 64 20 73 74 72 75 63 74 ..;; send struct
0900: 75 72 65 64 20 64 61 74 61 20 74 6f 20 72 65 63 ured data to rec
0910: 69 70 69 65 6e 74 0a 3b 3b 0a 3b 3b 20 20 4e 4f ipient.;;.;; NO
0920: 54 45 3a 20 71 72 79 6b 65 79 20 69 73 20 77 68 TE: qrykey is wh
0930: 61 74 20 77 61 73 20 63 61 6c 6c 65 64 20 74 68 at was called th
0940: 65 20 22 63 6f 6f 6b 69 65 22 20 70 72 65 76 69 e "cookie" previ
0950: 6f 75 73 6c 79 0a 3b 3b 0a 3b 3b 20 20 20 20 20 ously.;;.;;
0960: 72 65 74 76 61 6c 20 74 65 6c 6c 73 20 73 65 6e retval tells sen
0970: 64 20 74 6f 20 65 78 70 65 63 74 20 61 6e 64 20 d to expect and
0980: 77 61 69 74 20 66 6f 72 20 72 65 74 75 72 6e 20 wait for return
0990: 64 61 74 61 20 28 6f 6e 65 20 6c 69 6e 65 29 20 data (one line)
09a0: 61 6e 64 20 72 65 74 75 72 6e 20 69 74 20 6f 72 and return it or
09b0: 20 74 69 6d 65 20 6f 75 74 0a 3b 3b 20 20 20 20 time out.;;
09c0: 20 20 20 74 68 69 73 20 69 73 20 66 6f 72 20 70 this is for p
09d0: 69 6e 67 20 77 68 65 72 65 20 77 65 20 64 6f 6e ing where we don
09e0: 27 74 20 77 61 6e 74 20 74 6f 20 6e 65 63 65 73 't want to neces
09f0: 73 61 72 69 6c 79 20 68 61 76 65 20 73 65 74 20 sarily have set
0a00: 75 70 20 6f 75 72 20 6f 77 6e 20 73 65 72 76 65 up our own serve
0a10: 72 20 79 65 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e r yet..;;.(defin
0a20: 65 20 28 73 65 6e 64 20 75 64 61 74 61 20 68 6f e (send udata ho
0a30: 73 74 2d 70 6f 72 74 20 63 6d 64 20 71 72 79 6b st-port cmd qryk
0a40: 65 79 20 64 61 74 61 0a 09 20 20 20 20 20 20 23 ey data.. #
0a50: 21 6b 65 79 20 28 68 6f 73 74 6e 61 6d 65 20 23 !key (hostname #
0a60: 66 29 28 70 69 64 20 23 66 29 28 70 61 72 61 6d f)(pid #f)(param
0a70: 73 20 27 28 29 29 28 72 65 74 76 61 6c 20 23 66 s '())(retval #f
0a80: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6d 79 2d )). (let* ((my-
0a90: 68 6f 73 74 2d 70 6f 72 74 20 28 75 64 61 74 2d host-port (udat-
0aa0: 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 20 75 64 61 my-host-port uda
0ab0: 74 61 29 29 0a 09 20 28 69 73 6d 65 20 20 20 20 ta)).. (isme
0ac0: 20 20 20 20 20 28 65 71 75 61 6c 3f 20 68 6f 73 (equal? hos
0ad0: 74 2d 70 6f 72 74 20 6d 79 2d 68 6f 73 74 2d 70 t-port my-host-p
0ae0: 6f 72 74 29 29 20 3b 3b 20 61 6d 20 49 20 63 61 ort)) ;; am I ca
0af0: 6c 6c 69 6e 67 0a 09 09 09 09 09 09 09 3b 3b 20 lling........;;
0b00: 6d 79 73 65 6c 66 3f 0a 09 20 28 64 61 74 20 20 myself?.. (dat
0b10: 20 20 20 20 20 20 20 20 28 6c 69 73 74 0a 09 09 (list...
0b20: 09 63 6d 64 20 20 20 20 20 20 20 20 20 20 20 20 .cmd
0b30: 20 20 3b 3b 20 22 20 22 0a 09 09 09 6d 79 2d 68 ;; " "....my-h
0b40: 6f 73 74 2d 70 6f 72 74 20 20 20 20 20 20 20 20 ost-port
0b50: 20 3b 3b 20 22 20 22 0a 09 09 09 28 75 64 61 74 ;; " "....(udat
0b60: 2d 6d 79 2d 70 69 64 20 20 75 64 61 74 61 29 20 -my-pid udata)
0b70: 3b 3b 20 22 20 22 0a 09 09 09 71 72 79 6b 65 79 ;; " "....qrykey
0b80: 0a 09 09 09 70 61 72 61 6d 73 20 3b 3b 28 69 66 ....params ;;(if
0b90: 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 (null? params)
0ba0: 22 22 20 28 63 6f 6e 63 20 22 20 22 0a 09 09 09 "" (conc " "....
0bb0: 20 20 20 20 20 20 20 3b 3b 28 73 74 72 69 6e 67 ;;(string
0bc0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 61 72 -intersperse par
0bd0: 61 6d 73 20 22 20 22 29 29 29 0a 09 09 09 29 29 ams " ")))....))
0be0: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
0bf0: 22 73 65 6e 64 20 69 73 6d 65 20 69 73 20 22 20 "send isme is "
0c00: 28 69 66 20 69 73 6d 65 20 22 74 72 75 65 21 22 (if isme "true!"
0c10: 20 22 66 61 6c 73 65 21 22 29 20 22 2c 0a 20 20 "false!") ",.
0c20: 20 20 3b 3b 20 6d 79 2d 68 6f 73 74 2d 70 6f 72 ;; my-host-por
0c30: 74 3a 20 22 20 6d 79 2d 68 6f 73 74 2d 70 6f 72 t: " my-host-por
0c40: 74 20 22 2c 20 68 6f 73 74 2d 70 6f 72 74 3a 20 t ", host-port:
0c50: 22 20 68 6f 73 74 2d 70 6f 72 74 29 0a 20 20 20 " host-port).
0c60: 20 28 69 66 20 69 73 6d 65 0a 09 28 75 6c 65 78 (if isme..(ulex
0c70: 2d 68 61 6e 64 6c 65 72 20 75 64 61 74 61 20 64 -handler udata d
0c80: 61 74 20 64 61 74 61 29 0a 09 28 68 61 6e 64 6c at data)..(handl
0c90: 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 3b 3b 20 e-exceptions ;;
0ca0: 45 52 52 4f 52 20 2d 20 4d 41 4b 45 20 54 48 49 ERROR - MAKE THI
0cb0: 53 20 45 58 43 45 50 54 49 4f 4e 20 48 41 4e 44 S EXCEPTION HAND
0cc0: 4c 45 52 20 4d 4f 52 45 0a 09 09 09 20 20 20 3b LER MORE.... ;
0cd0: 3b 20 53 50 45 43 49 46 49 43 0a 09 20 20 20 20 ; SPECIFIC..
0ce0: 65 78 6e 0a 09 20 20 20 20 23 66 20 0a 09 20 20 exn.. #f ..
0cf0: 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 69 (let-values (((i
0d00: 6e 70 20 6f 75 70 29 28 74 63 70 2d 63 6f 6e 6e np oup)(tcp-conn
0d10: 65 63 74 20 68 6f 73 74 2d 70 6f 72 74 29 29 29 ect host-port)))
0d20: 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b .. ;;.. ;;
0d30: 20 43 4f 4e 54 52 4f 4c 20 4c 49 4e 45 3a 0a 09 CONTROL LINE:..
0d40: 20 20 20 20 3b 3b 20 20 20 20 63 6d 64 6b 65 79 ;; cmdkey
0d50: 20 68 6f 73 74 3a 70 6f 72 74 20 70 69 64 20 71 host:port pid q
0d60: 72 79 6b 65 79 20 70 61 72 61 6d 73 20 2e 2e 2e rykey params ...
0d70: 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 6c .. ;;.. (l
0d80: 65 74 20 28 28 72 65 73 0a 09 09 20 20 20 28 69 et ((res... (i
0d90: 66 20 28 61 6e 64 20 69 6e 70 20 6f 75 70 29 0a f (and inp oup).
0da0: 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 .. (let* (
0db0: 29 0a 09 09 09 20 28 69 66 20 6d 79 2d 68 6f 73 ).... (if my-hos
0dc0: 74 2d 70 6f 72 74 0a 09 09 09 20 20 20 20 20 28 t-port.... (
0dd0: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 begin....
0de0: 28 77 72 69 74 65 20 64 61 74 20 20 6f 75 70 29 (write dat oup)
0df0: 0a 09 09 09 20 20 20 20 20 20 20 28 77 72 69 74 .... (writ
0e00: 65 20 64 61 74 61 20 6f 75 70 29 20 3b 3b 20 73 e data oup) ;; s
0e10: 65 6e 64 20 61 73 20 73 65 78 70 72 0a 09 09 09 end as sexpr....
0e20: 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ;; (print
0e30: 20 22 53 65 6e 74 20 64 61 74 3a 20 22 20 64 61 "Sent dat: " da
0e40: 74 20 22 20 64 61 74 61 3a 20 22 20 64 61 74 61 t " data: " data
0e50: 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 ).... (if
0e60: 72 65 74 76 61 6c 0a 09 09 09 09 20 20 20 28 72 retval..... (r
0e70: 65 61 64 20 69 6e 70 29 0a 09 09 09 09 20 20 20 ead inp).....
0e80: 23 74 29 29 0a 09 09 09 20 20 20 20 20 28 62 65 #t)).... (be
0e90: 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 70 gin.... (p
0ea0: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 73 65 6e rint "ERROR: sen
0eb0: 64 20 63 61 6c 6c 65 64 20 62 75 74 20 6e 6f 20 d called but no
0ec0: 72 65 63 65 69 76 65 72 20 68 61 73 20 62 65 65 receiver has bee
0ed0: 6e 20 73 65 74 75 70 2e 20 50 6c 65 61 73 65 20 n setup. Please
0ee0: 63 61 6c 6c 20 73 65 74 75 70 20 66 69 72 73 74 call setup first
0ef0: 21 22 29 0a 09 09 09 20 20 20 20 20 20 20 23 66 !").... #f
0f00: 29 29 0a 09 09 09 20 3b 3b 20 4e 4f 54 45 3a 20 )).... ;; NOTE:
0f10: 44 4f 20 4e 4f 54 20 42 45 20 54 45 4d 50 54 45 DO NOT BE TEMPTE
0f20: 44 20 54 4f 20 4c 4f 4f 4b 20 41 54 20 41 4e 59 D TO LOOK AT ANY
0f30: 20 44 41 54 41 20 4f 4e 20 49 4e 50 20 48 45 52 DATA ON INP HER
0f40: 45 21 0a 09 09 09 20 3b 3b 20 20 20 20 20 20 20 E!.... ;;
0f50: 28 74 68 65 72 65 20 69 73 20 61 20 6c 69 73 74 (there is a list
0f60: 65 6e 65 72 20 66 6f 72 20 68 61 6e 64 6c 69 6e ener for handlin
0f70: 67 20 74 68 61 74 29 0a 09 09 09 20 29 0a 09 09 g that).... )...
0f80: 20 20 20 20 20 20 20 23 66 29 29 29 20 3b 3b 20 #f))) ;;
0f90: 23 66 20 6d 65 61 6e 73 20 66 61 69 6c 65 64 20 #f means failed
0fa0: 74 6f 20 63 6f 6e 6e 65 63 74 20 61 6e 64 20 73 to connect and s
0fb0: 65 6e 64 0a 09 20 20 20 20 20 20 28 63 6c 6f 73 end.. (clos
0fc0: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 e-input-port inp
0fd0: 29 0a 09 20 20 20 20 20 20 28 63 6c 6f 73 65 2d ).. (close-
0fe0: 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 output-port oup)
0ff0: 0a 09 20 20 20 20 20 20 72 65 73 29 29 29 29 29 .. res)))))
1000: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
1010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 6c ===========.;; l
1050: 69 73 74 65 6e 65 72 0a 3b 3b 3d 3d 3d 3d 3d 3d istener.;;======
1060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10a0: 0a 3b 3b 20 63 72 65 61 74 65 20 61 20 74 63 70 .;; create a tcp
10b0: 20 6c 69 73 74 65 6e 65 72 20 61 6e 64 20 72 65 listener and re
10c0: 74 75 72 6e 20 61 20 70 6f 70 75 6c 61 74 65 64 turn a populated
10d0: 20 75 64 61 74 20 73 74 72 75 63 74 20 77 69 74 udat struct wit
10e0: 68 0a 3b 3b 20 6d 79 20 70 6f 72 74 2c 20 61 64 h.;; my port, ad
10f0: 64 72 65 73 73 2c 20 68 6f 73 74 6e 61 6d 65 2c dress, hostname,
1100: 20 70 69 64 20 65 74 63 2e 0a 3b 3b 20 72 65 74 pid etc..;; ret
1110: 75 72 6e 20 23 66 20 69 66 20 66 61 69 6c 20 74 urn #f if fail t
1120: 6f 20 66 69 6e 64 20 61 20 70 6f 72 74 20 74 6f o find a port to
1130: 20 61 6c 6c 6f 63 61 74 65 2e 0a 3b 3b 0a 3b 3b allocate..;;.;;
1140: 20 20 69 66 20 75 64 61 74 61 2d 69 6e 20 69 73 if udata-in is
1150: 20 23 66 20 63 72 65 61 74 65 20 74 68 65 20 72 #f create the r
1160: 65 63 6f 72 64 0a 3b 3b 20 20 69 66 20 74 68 65 ecord.;; if the
1170: 72 65 20 69 73 20 61 6c 72 65 61 64 79 20 61 20 re is already a
1180: 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 72 65 serv-listener re
1190: 74 75 72 6e 20 74 68 65 20 75 64 61 74 61 0a 3b turn the udata.;
11a0: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 74 75 70 ;.(define (setup
11b0: 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e 6e 20 -listener uconn
11c0: 23 21 6f 70 74 69 6f 6e 61 6c 20 28 70 6f 72 74 #!optional (port
11d0: 20 34 32 34 32 29 29 0a 20 20 28 68 61 6e 64 6c 4242)). (handl
11e0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
11f0: 65 78 6e 0a 20 20 20 28 69 66 20 28 3c 20 70 6f exn. (if (< po
1200: 72 74 20 36 35 35 33 35 29 0a 20 20 20 20 20 20 rt 65535).
1210: 20 28 73 65 74 75 70 2d 6c 69 73 74 65 6e 65 72 (setup-listener
1220: 20 75 63 6f 6e 6e 20 28 2b 20 70 6f 72 74 20 31 uconn (+ port 1
1230: 29 29 0a 20 20 20 20 20 20 20 23 66 29 0a 20 20 )). #f).
1240: 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 74 65 6e (connect-listen
1250: 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 29 29 29 er uconn port)))
1260: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 6e 65 ..(define (conne
1270: 63 74 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e ct-listener ucon
1280: 6e 20 70 6f 72 74 29 0a 20 20 3b 3b 20 28 74 63 n port). ;; (tc
1290: 70 2d 6c 69 73 74 65 6e 65 72 2d 73 6f 63 6b 65 p-listener-socke
12a0: 74 20 4c 49 53 54 45 4e 45 52 29 28 73 6f 63 6b t LISTENER)(sock
12b0: 65 74 2d 6e 61 6d 65 20 73 6f 29 0a 20 20 3b 3b et-name so). ;;
12c0: 20 73 6f 63 6b 61 64 64 72 2d 61 64 64 72 65 73 sockaddr-addres
12d0: 73 2c 20 73 6f 63 6b 61 64 64 72 2d 70 6f 72 74 s, sockaddr-port
12e0: 2c 20 73 6f 63 6b 61 64 64 72 2d 3e 73 74 72 69 , sockaddr->stri
12f0: 6e 67 0a 20 20 28 6c 65 74 2a 20 28 28 74 6c 73 ng. (let* ((tls
1300: 6e 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 70 6f n (tcp-listen po
1310: 72 74 20 31 30 30 30 20 23 66 29 29 20 3b 3b 20 rt 1000 #f)) ;;
1320: 28 74 63 70 2d 6c 69 73 74 65 6e 20 54 43 50 50 (tcp-listen TCPP
1330: 4f 52 54 20 5b 42 41 43 4b 4c 4f 47 20 5b 48 4f ORT [BACKLOG [HO
1340: 53 54 5d 5d 29 0a 09 20 28 61 64 64 72 20 28 67 ST]]).. (addr (g
1350: 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 et-my-best-addre
1360: 73 73 29 29 29 20 3b 3b 20 28 68 6f 73 74 69 6e ss))) ;; (hostin
1370: 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f fo-addresses (ho
1380: 73 74 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 st-information (
1390: 63 75 72 72 65 6e 74 2d 68 6f 73 74 6e 61 6d 65 current-hostname
13a0: 29 29 29 0a 20 20 20 20 28 75 64 61 74 2d 6d 79 ))). (udat-my
13b0: 2d 61 64 64 72 65 73 73 2d 73 65 74 21 20 20 20 -address-set!
13c0: 20 75 63 6f 6e 6e 20 61 64 64 72 29 0a 20 20 20 uconn addr).
13d0: 20 28 75 64 61 74 2d 6d 79 2d 70 6f 72 74 2d 73 (udat-my-port-s
13e0: 65 74 21 20 20 20 20 20 20 20 75 63 6f 6e 6e 20 et! uconn
13f0: 70 6f 72 74 29 0a 20 20 20 20 28 75 64 61 74 2d port). (udat-
1400: 6d 79 2d 68 6f 73 74 6e 61 6d 65 2d 73 65 74 21 my-hostname-set!
1410: 20 20 20 75 63 6f 6e 6e 20 28 67 65 74 2d 68 6f uconn (get-ho
1420: 73 74 2d 6e 61 6d 65 29 29 0a 20 20 20 20 28 75 st-name)). (u
1430: 64 61 74 2d 73 65 72 76 2d 6c 69 73 74 65 6e 65 dat-serv-listene
1440: 72 2d 73 65 74 21 20 75 63 6f 6e 6e 20 74 6c 73 r-set! uconn tls
1450: 6e 29 0a 20 20 20 20 75 63 6f 6e 6e 29 29 0a 0a n). uconn))..
1460: 28 64 65 66 69 6e 65 20 28 75 64 61 74 2d 6d 79 (define (udat-my
1470: 2d 68 6f 73 74 2d 70 6f 72 74 20 75 63 6f 6e 6e -host-port uconn
1480: 29 0a 20 20 28 69 66 20 28 61 6e 64 20 28 75 64 ). (if (and (ud
1490: 61 74 2d 6d 79 2d 61 64 64 72 65 73 73 20 75 63 at-my-address uc
14a0: 6f 6e 6e 29 28 75 64 61 74 2d 6d 79 2d 70 6f 72 onn)(udat-my-por
14b0: 74 20 75 63 6f 6e 6e 29 29 0a 20 20 20 20 20 20 t uconn)).
14c0: 28 63 6f 6e 63 20 28 75 64 61 74 2d 6d 79 2d 61 (conc (udat-my-a
14d0: 64 64 72 65 73 73 20 75 63 6f 6e 6e 29 20 22 3a ddress uconn) ":
14e0: 22 20 28 75 64 61 74 2d 6d 79 2d 70 6f 72 74 20 " (udat-my-port
14f0: 75 63 6f 6e 6e 29 29 0a 20 20 20 20 20 20 23 66 uconn)). #f
1500: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
1510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
1550: 70 65 65 72 73 20 61 6e 64 20 63 6f 6e 6e 65 63 peers and connec
1560: 74 69 6f 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d tions.;;========
1570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
15b0: 3b 3b 20 73 65 6e 64 20 73 74 72 75 63 74 75 72 ;; send structur
15c0: 65 64 20 64 61 74 61 20 74 6f 20 72 65 63 69 70 ed data to recip
15d0: 69 65 6e 74 0a 3b 3b 0a 3b 3b 20 20 4e 4f 54 45 ient.;;.;; NOTE
15e0: 3a 20 71 72 79 6b 65 79 20 69 73 20 77 68 61 74 : qrykey is what
15f0: 20 77 61 73 20 63 61 6c 6c 65 64 20 74 68 65 20 was called the
1600: 22 63 6f 6f 6b 69 65 22 20 70 72 65 76 69 6f 75 "cookie" previou
1610: 73 6c 79 0a 3b 3b 0a 3b 3b 20 20 20 20 20 72 65 sly.;;.;; re
1620: 74 76 61 6c 20 74 65 6c 6c 73 20 73 65 6e 64 20 tval tells send
1630: 74 6f 20 65 78 70 65 63 74 20 61 6e 64 20 77 61 to expect and wa
1640: 69 74 20 66 6f 72 20 72 65 74 75 72 6e 20 64 61 it for return da
1650: 74 61 20 28 6f 6e 65 20 6c 69 6e 65 29 20 61 6e ta (one line) an
1660: 64 20 72 65 74 75 72 6e 20 69 74 20 6f 72 20 74 d return it or t
1670: 69 6d 65 20 6f 75 74 0a 3b 3b 20 20 20 20 20 20 ime out.;;
1680: 20 74 68 69 73 20 69 73 20 66 6f 72 20 70 69 6e this is for pin
1690: 67 20 77 68 65 72 65 20 77 65 20 64 6f 6e 27 74 g where we don't
16a0: 20 77 61 6e 74 20 74 6f 20 6e 65 63 65 73 73 61 want to necessa
16b0: 72 69 6c 79 20 68 61 76 65 20 73 65 74 20 75 70 rily have set up
16c0: 20 6f 75 72 20 6f 77 6e 20 73 65 72 76 65 72 20 our own server
16d0: 79 65 74 2e 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a yet..;;.;; NOTE:
16e0: 20 73 65 65 20 62 65 6c 6f 77 20 66 6f 72 20 62 see below for b
16f0: 65 67 69 6e 6e 69 6e 67 73 20 6f 66 20 63 6f 64 eginnings of cod
1700: 65 20 74 6f 20 61 6c 6c 6f 77 20 72 65 2d 75 73 e to allow re-us
1710: 65 20 6f 66 20 74 63 70 20 63 6f 6e 6e 65 63 74 e of tcp connect
1720: 69 6f 6e 73 0a 3b 3b 20 20 20 20 20 20 20 20 2d ions.;; -
1730: 20 49 20 62 65 6c 69 65 76 65 20 28 77 69 74 68 I believe (with
1740: 6f 75 74 20 73 75 62 73 74 61 6e 74 69 61 6c 20 out substantial
1750: 65 76 69 64 65 6e 63 65 29 20 74 68 61 74 20 72 evidence) that r
1760: 65 2d 75 73 69 6e 67 20 63 6f 6e 6e 65 63 74 69 e-using connecti
1770: 6f 6e 73 20 77 69 6c 6c 0a 3b 3b 20 20 20 20 20 ons will.;;
1780: 20 20 20 20 20 62 65 20 62 65 6e 65 66 69 63 69 be benefici
1790: 61 6c 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 66 69 6e al ....;;.(defin
17a0: 65 20 28 73 65 6e 64 20 75 64 61 74 61 20 68 6f e (send udata ho
17b0: 73 74 2d 70 6f 72 74 20 63 6d 64 20 71 72 79 6b st-port cmd qryk
17c0: 65 79 20 64 61 74 61 0a 09 20 20 20 20 20 20 23 ey data.. #
17d0: 21 6b 65 79 20 28 68 6f 73 74 6e 61 6d 65 20 23 !key (hostname #
17e0: 66 29 28 70 69 64 20 23 66 29 28 70 61 72 61 6d f)(pid #f)(param
17f0: 73 20 27 28 29 29 28 72 65 74 76 61 6c 20 23 66 s '())(retval #f
1800: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6d 79 2d )). (let* ((my-
1810: 68 6f 73 74 2d 70 6f 72 74 20 28 75 64 61 74 2d host-port (udat-
1820: 68 6f 73 74 2d 70 6f 72 74 20 75 64 61 74 61 29 host-port udata)
1830: 29 0a 09 20 28 69 73 6d 65 20 20 20 20 20 20 20 ).. (isme
1840: 20 20 28 65 71 75 61 6c 3f 20 68 6f 73 74 2d 70 (equal? host-p
1850: 6f 72 74 20 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 ort my-host-port
1860: 29 29 20 3b 3b 20 61 6d 20 49 20 63 61 6c 6c 69 )) ;; am I calli
1870: 6e 67 0a 09 09 09 09 09 09 09 3b 3b 20 6d 79 73 ng........;; mys
1880: 65 6c 66 3f 0a 09 20 28 64 61 74 20 20 20 20 20 elf?.. (dat
1890: 20 20 20 20 20 28 6c 69 73 74 0a 09 09 09 63 6d (list....cm
18a0: 64 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b d ;
18b0: 3b 20 22 20 22 0a 09 09 09 6d 79 2d 68 6f 73 74 ; " "....my-host
18c0: 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 3b 3b -port ;;
18d0: 20 22 20 22 0a 09 09 09 71 72 79 6b 65 79 0a 09 " "....qrykey..
18e0: 09 09 70 61 72 61 6d 73 0a 09 09 09 29 29 29 0a ..params....))).
18f0: 20 20 20 20 28 69 66 20 69 73 6d 65 0a 09 28 75 (if isme..(u
1900: 6c 65 78 2d 68 61 6e 64 6c 65 72 20 75 64 61 74 lex-handler udat
1910: 61 20 64 61 74 20 64 61 74 61 29 0a 09 28 68 61 a dat data)..(ha
1920: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 ndle-exceptions
1930: 3b 3b 20 54 4f 44 4f 20 2d 20 4d 41 4b 45 20 54 ;; TODO - MAKE T
1940: 48 49 53 20 45 58 43 45 50 54 49 4f 4e 20 43 4d HIS EXCEPTION CM
1950: 44 20 53 50 45 43 49 46 49 43 0a 09 20 20 20 20 D SPECIFIC..
1960: 65 78 6e 0a 09 20 20 20 20 23 66 20 0a 09 20 20 exn.. #f ..
1970: 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 69 (let-values (((i
1980: 6e 70 20 6f 75 70 29 28 74 63 70 2d 63 6f 6e 6e np oup)(tcp-conn
1990: 65 63 74 20 68 6f 73 74 2d 70 6f 72 74 29 29 29 ect host-port)))
19a0: 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b .. ;;.. ;;
19b0: 20 43 4f 4e 54 52 4f 4c 20 4c 49 4e 45 3a 0a 09 CONTROL LINE:..
19c0: 20 20 20 20 3b 3b 20 20 20 20 63 6d 64 6b 65 79 ;; cmdkey
19d0: 20 68 6f 73 74 3a 70 6f 72 74 20 70 69 64 20 71 host:port pid q
19e0: 72 79 6b 65 79 20 70 61 72 61 6d 73 20 2e 2e 2e rykey params ...
19f0: 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 6c .. ;;.. (l
1a00: 65 74 20 28 28 72 65 73 20 28 69 66 20 28 61 6e et ((res (if (an
1a10: 64 20 69 6e 70 20 6f 75 70 29 0a 09 09 09 20 20 d inp oup)....
1a20: 20 28 69 66 20 6d 79 2d 68 6f 73 74 2d 70 6f 72 (if my-host-por
1a30: 74 0a 09 09 09 20 20 20 20 20 20 20 28 62 65 67 t.... (beg
1a40: 69 6e 0a 09 09 09 09 20 28 77 72 69 74 65 20 64 in..... (write d
1a50: 61 74 20 20 6f 75 70 29 0a 09 09 09 09 20 28 77 at oup)..... (w
1a60: 72 69 74 65 20 64 61 74 61 20 6f 75 70 29 20 3b rite data oup) ;
1a70: 3b 20 73 65 6e 64 20 61 73 20 73 65 78 70 72 0a ; send as sexpr.
1a80: 09 09 09 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 .... ;; (print "
1a90: 53 65 6e 74 20 64 61 74 3a 20 22 20 64 61 74 20 Sent dat: " dat
1aa0: 22 20 64 61 74 61 3a 20 22 20 64 61 74 61 29 0a " data: " data).
1ab0: 09 09 09 09 20 28 69 66 20 72 65 74 76 61 6c 0a .... (if retval.
1ac0: 09 09 09 09 20 20 20 20 20 28 72 65 61 64 20 69 .... (read i
1ad0: 6e 70 29 0a 09 09 09 09 20 20 20 20 20 23 74 29 np)..... #t)
1ae0: 29 0a 09 09 09 20 20 20 20 20 20 20 28 62 65 67 ).... (beg
1af0: 69 6e 0a 09 09 09 09 20 28 70 72 69 6e 74 20 22 in..... (print "
1b00: 45 52 52 4f 52 3a 20 73 65 6e 64 20 63 61 6c 6c ERROR: send call
1b10: 65 64 20 62 75 74 20 6e 6f 20 72 65 63 65 69 76 ed but no receiv
1b20: 65 72 20 68 61 73 20 62 65 65 6e 20 73 65 74 75 er has been setu
1b30: 70 2e 20 50 6c 65 61 73 65 20 63 61 6c 6c 20 73 p. Please call s
1b40: 65 74 75 70 20 66 69 72 73 74 21 22 29 0a 09 09 etup first!")...
1b50: 09 09 20 23 66 29 29 0a 09 09 09 20 20 20 3b 3b .. #f)).... ;;
1b60: 20 4e 4f 54 45 3a 20 44 4f 20 4e 4f 54 20 42 45 NOTE: DO NOT BE
1b70: 20 54 45 4d 50 54 45 44 20 54 4f 20 4c 4f 4f 4b TEMPTED TO LOOK
1b80: 20 41 54 20 41 4e 59 20 44 41 54 41 20 4f 4e 20 AT ANY DATA ON
1b90: 49 4e 50 20 48 45 52 45 21 0a 09 09 09 20 20 20 INP HERE!....
1ba0: 3b 3b 20 20 20 20 20 20 20 28 74 68 65 72 65 20 ;; (there
1bb0: 69 73 20 61 20 6c 69 73 74 65 6e 65 72 20 66 6f is a listener fo
1bc0: 72 20 68 61 6e 64 6c 69 6e 67 20 74 68 61 74 29 r handling that)
1bd0: 0a 09 09 09 20 20 20 23 66 29 29 29 20 3b 3b 20 .... #f))) ;;
1be0: 23 66 20 6d 65 61 6e 73 20 66 61 69 6c 65 64 20 #f means failed
1bf0: 74 6f 20 63 6f 6e 6e 65 63 74 20 61 6e 64 20 73 to connect and s
1c00: 65 6e 64 0a 09 20 20 20 20 20 20 28 63 6c 6f 73 end.. (clos
1c10: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 e-input-port inp
1c20: 29 0a 09 20 20 20 20 20 20 28 63 6c 6f 73 65 2d ).. (close-
1c30: 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 output-port oup)
1c40: 0a 09 20 20 20 20 20 20 72 65 73 29 29 29 29 29 .. res)))))
1c50: 29 0a 0a 3b 3b 20 73 65 6e 64 20 61 20 72 65 71 )..;; send a req
1c60: 75 65 73 74 20 74 6f 20 74 68 65 20 67 69 76 65 uest to the give
1c70: 6e 20 68 6f 73 74 2d 70 6f 72 74 20 61 6e 64 20 n host-port and
1c80: 72 65 67 69 73 74 65 72 20 61 20 6d 61 69 6c 62 register a mailb
1c90: 6f 78 20 69 6e 20 75 64 61 74 61 0a 3b 3b 20 77 ox in udata.;; w
1ca0: 61 69 74 20 66 6f 72 20 74 68 65 20 6d 61 69 6c ait for the mail
1cb0: 62 6f 78 20 64 61 74 61 20 61 6e 64 20 72 65 74 box data and ret
1cc0: 75 72 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 6e urn it.;;.(defin
1cd0: 65 20 28 73 65 6e 64 2d 72 65 63 65 69 76 65 20 e (send-receive
1ce0: 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 20 udata host-port
1cf0: 63 6d 64 20 71 72 79 6b 65 79 20 64 61 74 61 20 cmd qrykey data
1d00: 23 21 6b 65 79 20 28 68 6f 73 74 6e 61 6d 65 20 #!key (hostname
1d10: 23 66 29 28 70 69 64 20 23 66 29 28 70 61 72 61 #f)(pid #f)(para
1d20: 6d 73 20 27 28 29 29 28 74 69 6d 65 6f 75 74 20 ms '())(timeout
1d30: 32 30 29 29 0a 20 20 28 6c 65 74 20 28 28 6d 62 20)). (let ((mb
1d40: 6f 78 20 20 20 20 20 20 28 6d 61 6b 65 2d 6d 61 ox (make-ma
1d50: 69 6c 62 6f 78 29 29 0a 09 28 6d 62 6f 78 2d 74 ilbox))..(mbox-t
1d60: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c ime (current-mil
1d70: 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 28 6d 62 liseconds))..(mb
1d80: 6f 78 65 73 20 20 20 20 28 75 64 61 74 2d 6d 62 oxes (udat-mb
1d90: 6f 78 65 73 20 75 64 61 74 61 29 29 29 0a 20 20 oxes udata))).
1da0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
1db0: 74 21 20 6d 62 6f 78 65 73 20 71 72 79 6b 65 79 t! mboxes qrykey
1dc0: 20 6d 62 6f 78 29 0a 20 20 20 20 28 69 66 20 28 mbox). (if (
1dd0: 73 65 6e 64 20 75 64 61 74 61 20 68 6f 73 74 2d send udata host-
1de0: 70 6f 72 74 20 63 6d 64 20 71 72 79 6b 65 79 20 port cmd qrykey
1df0: 64 61 74 61 20 68 6f 73 74 6e 61 6d 65 3a 20 68 data hostname: h
1e00: 6f 73 74 6e 61 6d 65 20 70 69 64 3a 20 70 69 64 ostname pid: pid
1e10: 20 70 61 72 61 6d 73 3a 20 70 61 72 61 6d 73 29 params: params)
1e20: 0a 09 28 6c 65 74 2a 20 28 28 6d 62 6f 78 2d 74 ..(let* ((mbox-t
1e30: 69 6d 65 6f 75 74 2d 73 65 63 73 20 20 20 20 74 imeout-secs t
1e40: 69 6d 65 6f 75 74 29 0a 09 20 20 20 20 20 20 20 imeout)..
1e50: 28 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d 72 65 (mbox-timeout-re
1e60: 73 75 6c 74 20 27 4d 42 4f 58 5f 54 49 4d 45 4f sult 'MBOX_TIMEO
1e70: 55 54 29 0a 09 20 20 20 20 20 20 20 28 72 65 73 UT).. (res
1e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e90: 20 20 28 6d 61 69 6c 62 6f 78 2d 72 65 63 65 69 (mailbox-recei
1ea0: 76 65 21 20 6d 62 6f 78 20 6d 62 6f 78 2d 74 69 ve! mbox mbox-ti
1eb0: 6d 65 6f 75 74 2d 73 65 63 73 20 6d 62 6f 78 2d meout-secs mbox-
1ec0: 74 69 6d 65 6f 75 74 2d 72 65 73 75 6c 74 29 29 timeout-result))
1ed0: 0a 09 20 20 20 20 20 20 20 28 6d 62 6f 78 2d 72 .. (mbox-r
1ee0: 65 63 65 69 76 65 2d 74 69 6d 65 20 20 20 20 28 eceive-time (
1ef0: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
1f00: 6f 6e 64 73 29 29 29 0a 09 20 20 28 68 61 73 68 onds))).. (hash
1f10: 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 6d -table-delete! m
1f20: 62 6f 78 65 73 20 71 72 79 6b 65 79 29 0a 09 20 boxes qrykey)..
1f30: 20 28 69 66 20 28 65 71 3f 20 72 65 73 20 27 4d (if (eq? res 'M
1f40: 42 4f 58 5f 54 49 4d 45 4f 55 54 29 0a 09 20 20 BOX_TIMEOUT)..
1f50: 20 20 20 20 23 66 0a 09 20 20 20 20 20 20 72 65 #f.. re
1f60: 73 29 29 0a 09 23 66 29 29 29 20 3b 3b 20 23 66 s))..#f))) ;; #f
1f70: 20 6d 65 61 6e 73 20 66 61 69 6c 65 64 20 74 6f means failed to
1f80: 20 63 6f 6d 6d 75 6e 69 63 61 74 65 0a 0a 3b 3b communicate..;;
1f90: 20 0a 28 64 65 66 69 6e 65 20 28 75 6c 65 78 2d .(define (ulex-
1fa0: 68 61 6e 64 6c 65 72 20 75 64 61 74 61 20 63 6f handler udata co
1fb0: 6e 74 72 6f 6c 64 61 74 20 64 61 74 61 29 0a 20 ntroldat data).
1fc0: 20 28 70 72 69 6e 74 20 22 63 6f 6e 74 72 6f 6c (print "control
1fd0: 64 61 74 3a 20 22 20 63 6f 6e 74 72 6f 6c 64 61 dat: " controlda
1fe0: 74 20 22 20 64 61 74 61 3a 20 22 20 64 61 74 61 t " data: " data
1ff0: 29 0a 20 20 28 6d 61 74 63 68 20 63 6f 6e 74 72 ). (match contr
2000: 6f 6c 64 61 74 20 3b 3b 20 20 28 73 74 72 69 6e oldat ;; (strin
2010: 67 2d 73 70 6c 69 74 20 63 6f 6e 74 72 6f 6c 64 g-split controld
2020: 61 74 29 0a 20 20 20 20 28 28 63 6d 64 6b 65 79 at). ((cmdkey
2030: 20 68 6f 73 74 2d 70 6f 72 74 20 70 69 64 20 71 host-port pid q
2040: 72 79 6b 65 79 20 70 61 72 61 6d 73 20 2e 2e 2e rykey params ...
2050: 29 0a 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ). ;; (print
2060: 20 22 63 6d 64 6b 65 79 3a 20 22 20 63 6d 64 6b "cmdkey: " cmdk
2070: 65 79 20 22 20 68 6f 73 74 2d 70 6f 72 74 3a 20 ey " host-port:
2080: 22 20 68 6f 73 74 2d 70 6f 72 74 20 22 20 70 69 " host-port " pi
2090: 64 3a 20 22 20 70 69 64 20 22 20 71 72 79 6b 65 d: " pid " qryke
20a0: 79 3a 20 22 20 71 72 79 6b 65 79 20 22 20 70 61 y: " qrykey " pa
20b0: 72 61 6d 73 3a 20 22 20 70 61 72 61 6d 73 29 0a rams: " params).
20c0: 20 20 20 20 20 28 63 61 73 65 20 63 6d 64 6b 65 (case cmdke
20d0: 79 20 3b 3b 20 28 73 74 72 69 6e 67 2d 3e 73 79 y ;; (string->sy
20e0: 6d 62 6f 6c 20 63 6d 64 6b 65 79 29 0a 20 20 20 mbol cmdkey).
20f0: 20 20 20 20 28 28 61 63 6b 29 28 70 72 69 6e 74 ((ack)(print
2100: 20 22 47 6f 74 20 61 63 6b 21 22 29 29 0a 20 20 "Got ack!")).
2110: 20 20 20 20 20 28 28 70 69 6e 67 29 20 3b 3b 20 ((ping) ;;
2120: 73 70 65 63 69 61 6c 20 63 61 73 65 20 2d 20 72 special case - r
2130: 65 74 75 72 6e 20 72 65 73 75 6c 74 20 69 6d 6d eturn result imm
2140: 65 64 69 61 74 65 6c 79 20 6f 6e 20 74 68 65 20 ediately on the
2150: 73 61 6d 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a same connection.
2160: 09 28 6c 65 74 2a 20 28 28 70 72 6f 63 20 20 28 .(let* ((proc (
2170: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
2180: 65 66 61 75 6c 74 20 28 75 64 61 74 2d 68 61 6e efault (udat-han
2190: 64 6c 65 72 73 20 75 64 61 74 61 29 20 27 70 69 dlers udata) 'pi
21a0: 6e 67 20 23 66 29 29 0a 09 20 20 20 20 20 20 20 ng #f))..
21b0: 28 76 61 6c 20 20 20 28 69 66 20 70 72 6f 63 20 (val (if proc
21c0: 28 70 72 6f 63 29 20 22 67 6f 74 70 69 6e 67 22 (proc) "gotping"
21d0: 29 29 0a 09 20 20 20 20 20 20 20 28 70 65 65 72 )).. (peer
21e0: 20 20 28 6d 61 6b 65 2d 70 65 65 72 20 61 64 64 (make-peer add
21f0: 72 2d 70 6f 72 74 3a 20 68 6f 73 74 2d 70 6f 72 r-port: host-por
2200: 74 20 70 69 64 3a 20 70 69 64 29 29 0a 09 20 20 t pid: pid))..
2210: 20 20 20 20 20 28 64 62 73 68 61 73 68 20 28 75 (dbshash (u
2220: 64 61 74 2d 64 62 6f 77 6e 65 72 73 20 75 64 61 dat-dbowners uda
2230: 74 61 29 29 29 0a 09 20 20 28 70 65 65 72 2d 64 ta))).. (peer-d
2240: 62 73 2d 73 65 74 21 20 70 65 65 72 20 70 61 72 bs-set! peer par
2250: 61 6d 73 29 20 3b 3b 20 70 61 72 61 6d 73 20 66 ams) ;; params f
2260: 6f 72 20 70 69 6e 67 20 69 73 20 6c 69 73 74 20 or ping is list
2270: 6f 66 20 64 62 73 20 6f 77 6e 65 64 20 62 79 20 of dbs owned by
2280: 70 69 6e 67 65 72 0a 09 20 20 28 66 6f 72 2d 65 pinger.. (for-e
2290: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 64 62 66 ach (lambda (dbf
22a0: 69 6c 65 29 0a 09 09 20 20 20 20 20 20 28 68 61 ile)... (ha
22b0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 64 62 sh-table-set! db
22c0: 73 68 61 73 68 20 64 62 66 69 6c 65 20 68 6f 73 shash dbfile hos
22d0: 74 2d 70 6f 72 74 29 29 20 3b 3b 20 57 52 4f 4e t-port)) ;; WRON
22e0: 47 3f 0a 09 09 20 20 20 20 70 61 72 61 6d 73 29 G?... params)
22f0: 20 3b 3b 20 72 65 67 69 73 74 65 72 20 65 61 63 ;; register eac
2300: 68 20 64 62 20 69 6e 20 74 68 65 20 64 62 73 68 h db in the dbsh
2310: 61 73 68 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 ash.. (if (not
2320: 28 68 61 73 68 2d 74 61 62 6c 65 2d 65 78 69 73 (hash-table-exis
2330: 74 73 3f 20 28 75 64 61 74 2d 70 65 65 72 73 20 ts? (udat-peers
2340: 75 64 61 74 61 29 20 68 6f 73 74 2d 70 6f 72 74 udata) host-port
2350: 29 29 0a 09 20 20 20 20 20 20 28 68 61 73 68 2d )).. (hash-
2360: 74 61 62 6c 65 2d 73 65 74 21 20 28 75 64 61 74 table-set! (udat
2370: 2d 70 65 65 72 73 20 75 64 61 74 61 29 20 68 6f -peers udata) ho
2380: 73 74 2d 70 6f 72 74 20 70 65 65 72 29 29 20 3b st-port peer)) ;
2390: 3b 20 73 61 76 65 20 74 68 65 20 64 65 74 61 69 ; save the detai
23a0: 6c 73 20 6f 66 20 74 68 69 73 20 63 61 6c 6c 65 ls of this calle
23b0: 72 20 69 6e 20 70 65 65 72 73 0a 09 20 20 71 72 r in peers.. qr
23c0: 79 6b 65 79 29 29 20 3b 3b 20 45 6e 64 20 6f 66 ykey)) ;; End of
23d0: 20 70 69 6e 67 0a 20 20 20 20 20 20 20 28 28 67 ping. ((g
23e0: 6f 6f 64 62 79 65 29 0a 09 3b 3b 20 72 65 6d 6f oodbye)..;; remo
23f0: 76 65 20 61 6c 6c 20 74 72 61 63 65 73 20 6f 66 ve all traces of
2400: 20 74 68 65 20 63 61 6c 6c 65 72 20 69 6e 20 64 the caller in d
2410: 62 20 6f 77 6e 65 72 73 68 69 70 20 65 74 63 2e b ownership etc.
2420: 0a 09 28 6c 65 74 2a 20 28 28 70 65 65 72 20 20 ..(let* ((peer
2430: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2440: 64 65 66 61 75 6c 74 20 28 75 64 61 74 2d 70 65 default (udat-pe
2450: 65 72 73 20 75 64 61 74 61 29 20 68 6f 73 74 2d ers udata) host-
2460: 70 6f 72 74 20 23 66 29 29 0a 09 20 20 20 20 20 port #f))..
2470: 20 20 28 64 62 73 20 20 20 28 69 66 20 70 65 65 (dbs (if pee
2480: 72 20 28 70 65 65 72 2d 64 62 73 20 70 65 65 72 r (peer-dbs peer
2490: 29 20 27 28 29 29 29 0a 09 20 20 20 20 20 20 20 ) '()))..
24a0: 28 64 62 73 68 61 73 68 20 28 75 64 61 74 2d 64 (dbshash (udat-d
24b0: 62 6f 77 6e 65 72 73 20 75 64 61 74 61 29 29 29 bowners udata)))
24c0: 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c .. (for-each (l
24d0: 61 6d 62 64 61 20 28 64 62 66 69 6c 65 29 28 68 ambda (dbfile)(h
24e0: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
24f0: 21 20 64 62 73 68 61 73 68 20 64 62 66 69 6c 65 ! dbshash dbfile
2500: 29 29 20 64 62 73 29 0a 09 20 20 28 68 61 73 68 )) dbs).. (hash
2510: 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 -table-delete! (
2520: 75 64 61 74 2d 70 65 65 72 73 20 75 64 61 74 61 udat-peers udata
2530: 29 20 68 6f 73 74 2d 70 6f 72 74 29 0a 09 20 20 ) host-port)..
2540: 71 72 79 6b 65 79 29 29 0a 20 20 20 20 20 20 20 qrykey)).
2550: 28 28 69 6d 6d 65 64 69 61 74 65 20 72 65 61 64 ((immediate read
2560: 2d 6f 6e 6c 79 20 6e 6f 72 6d 61 6c 20 6c 6f 77 -only normal low
2570: 2d 70 72 69 6f 72 69 74 79 29 20 3b 3b 20 64 6f -priority) ;; do
2580: 20 74 68 69 73 20 77 6f 72 6b 20 69 6d 6d 65 64 this work immed
2590: 69 61 74 65 6c 79 0a 09 3b 3b 20 68 6f 73 74 2d iately..;; host-
25a0: 70 6f 72 74 20 28 63 61 6c 6c 65 72 29 2c 20 70 port (caller), p
25b0: 69 64 20 28 63 61 6c 6c 65 72 29 2c 20 71 72 79 id (caller), qry
25c0: 6b 65 79 20 28 63 6f 6f 6b 69 65 29 2c 20 70 61 key (cookie), pa
25d0: 72 61 6d 73 20 3c 3d 20 61 6c 6c 20 66 72 6f 6d rams <= all from
25e0: 20 66 69 72 73 74 20 6c 69 6e 65 0a 09 3b 3b 20 first line..;;
25f0: 64 61 74 61 20 3d 3e 20 61 20 73 69 6e 67 6c 65 data => a single
2600: 20 6c 69 6e 65 20 65 6e 63 6f 64 65 64 20 68 6f line encoded ho
2610: 77 65 76 65 72 20 79 6f 75 20 77 61 6e 74 2c 20 wever you want,
2620: 6f 72 20 73 68 6f 75 6c 64 20 49 20 62 75 69 6c or should I buil
2630: 64 20 6a 73 6f 6e 20 69 6e 74 6f 20 69 74 3f 0a d json into it?.
2640: 09 28 70 72 69 6e 74 20 22 63 6d 64 6b 65 79 3d .(print "cmdkey=
2650: 22 20 63 6d 64 6b 65 79 29 0a 09 28 6c 65 74 2a " cmdkey)..(let*
2660: 20 28 28 70 64 61 74 20 28 67 65 74 2d 70 65 65 ((pdat (get-pee
2670: 72 2d 64 61 74 20 75 64 61 74 61 20 68 6f 73 74 r-dat udata host
2680: 2d 70 6f 72 74 29 29 29 0a 09 20 20 28 6d 61 74 -port))).. (mat
2690: 63 68 20 70 61 72 61 6d 73 20 3b 3b 20 64 62 66 ch params ;; dbf
26a0: 69 6c 65 20 70 72 6f 63 6b 65 79 20 70 72 6f 63 ile prockey proc
26b0: 70 61 72 61 6d 0a 09 20 20 20 20 28 28 64 62 66 param.. ((dbf
26c0: 69 6c 65 20 70 72 6f 63 6b 65 79 20 70 72 6f 63 ile prockey proc
26d0: 70 61 72 61 6d 29 0a 09 20 20 20 20 20 28 63 61 param).. (ca
26e0: 73 65 20 63 6d 64 6b 65 79 0a 09 20 20 20 20 20 se cmdkey..
26f0: 20 20 28 28 69 6d 6d 65 64 69 61 74 65 20 72 65 ((immediate re
2700: 61 64 2d 6f 6e 6c 79 29 0a 09 09 28 70 72 6f 63 ad-only)...(proc
2710: 65 73 73 2d 72 65 71 75 65 73 74 20 75 64 61 74 ess-request udat
2720: 61 20 70 64 61 74 20 64 62 66 69 6c 65 20 71 72 a pdat dbfile qr
2730: 79 6b 65 79 20 70 72 6f 63 6b 65 79 20 70 72 6f ykey prockey pro
2740: 63 70 61 72 61 6d 20 64 61 74 61 29 29 0a 09 20 cparam data))..
2750: 20 20 20 20 20 20 28 28 6e 6f 72 6d 61 6c 20 6c ((normal l
2760: 6f 77 2d 70 72 69 6f 72 69 74 79 29 20 3b 3b 20 ow-priority) ;;
2770: 73 70 6c 69 74 20 6f 66 66 20 6c 61 74 65 72 20 split off later
2780: 61 6e 64 20 61 64 64 20 6c 6f 67 69 63 20 74 6f and add logic to
2790: 20 73 75 70 70 6f 72 74 20 6c 6f 77 20 70 72 69 support low pri
27a0: 6f 72 69 74 79 0a 09 09 28 61 64 64 2d 74 6f 2d ority...(add-to-
27b0: 77 6f 72 6b 2d 71 75 65 75 65 20 75 64 61 74 61 work-queue udata
27c0: 20 70 64 61 74 20 64 62 66 69 6c 65 20 71 72 79 pdat dbfile qry
27d0: 6b 65 79 20 70 72 6f 63 6b 65 79 20 70 72 6f 63 key prockey proc
27e0: 70 61 72 61 6d 20 64 61 74 61 29 29 0a 09 20 20 param data))..
27f0: 20 20 20 20 20 28 65 6c 73 65 0a 09 09 23 66 29 (else...#f)
2800: 29 29 0a 09 20 20 20 20 28 65 6c 73 65 0a 09 20 )).. (else..
2810: 20 20 20 20 28 70 72 69 6e 74 20 22 49 4e 46 4f (print "INFO
2820: 3a 20 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d : params=" param
2830: 73 20 22 20 63 6d 64 6b 65 79 3d 22 20 63 6d 64 s " cmdkey=" cmd
2840: 6b 65 79 20 22 20 63 6f 6e 74 72 6f 6c 64 61 74 key " controldat
2850: 3d 22 20 63 6f 6e 74 72 6f 6c 64 61 74 29 0a 09 =" controldat)..
2860: 20 20 20 20 20 23 66 29 29 29 29 0a 20 20 20 20 #f)))).
2870: 20 20 20 28 65 6c 73 65 0a 09 28 61 64 64 2d 74 (else..(add-t
2880: 6f 2d 77 6f 72 6b 2d 71 75 65 75 65 20 75 64 61 o-work-queue uda
2890: 74 61 20 28 67 65 74 2d 70 65 65 72 2d 64 61 74 ta (get-peer-dat
28a0: 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 udata host-port
28b0: 29 20 63 6d 64 6b 65 79 20 71 72 79 6b 65 79 20 ) cmdkey qrykey
28c0: 64 61 74 61 29 0a 09 23 66 29 29 29 0a 20 20 20 data)..#f))).
28d0: 20 28 65 6c 73 65 0a 20 20 20 20 20 28 70 72 69 (else. (pri
28e0: 6e 74 20 22 42 41 44 20 44 41 54 41 3f 20 63 6f nt "BAD DATA? co
28f0: 6e 74 72 6f 6c 64 61 74 3d 22 20 63 6f 6e 74 72 ntroldat=" contr
2900: 6f 6c 64 61 74 20 22 20 64 61 74 61 3d 22 20 64 oldat " data=" d
2910: 61 74 61 29 0a 20 20 20 20 20 23 66 29 29 29 3b ata). #f)));
2920: 3b 20 68 61 6e 64 6c 65 73 20 74 68 65 20 69 6e ; handles the in
2930: 63 6f 6d 69 6e 67 20 6d 65 73 73 61 67 65 73 20 coming messages
2940: 61 6e 64 20 64 69 73 70 61 74 63 68 65 73 20 74 and dispatches t
2950: 6f 20 71 75 65 75 65 73 0a 0a 3b 3b 0a 28 64 65 o queues..;;.(de
2960: 66 69 6e 65 20 28 75 6c 65 78 2d 63 6d 64 2d 6c fine (ulex-cmd-l
2970: 6f 6f 70 20 75 64 61 74 61 29 0a 20 20 28 6c 65 oop udata). (le
2980: 74 2a 20 28 28 73 65 72 76 2d 6c 69 73 74 65 6e t* ((serv-listen
2990: 65 72 20 28 75 64 61 74 2d 73 65 72 76 2d 6c 69 er (udat-serv-li
29a0: 73 74 65 6e 65 72 20 75 64 61 74 61 29 29 29 0a stener udata))).
29b0: 20 20 20 20 3b 3b 20 64 61 74 61 20 63 6f 6d 65 ;; data come
29c0: 73 20 61 73 20 74 77 6f 20 6c 69 6e 65 73 0a 20 s as two lines.
29d0: 20 20 20 3b 3b 20 20 20 63 6d 64 6b 65 79 20 72 ;; cmdkey r
29e0: 65 73 70 2d 61 64 64 72 3a 72 65 73 70 2d 70 6f esp-addr:resp-po
29f0: 72 74 20 68 6f 73 74 6e 61 6d 65 20 70 69 64 20 rt hostname pid
2a00: 71 72 79 6b 65 79 20 5b 64 62 70 61 74 68 2f 64 qrykey [dbpath/d
2a10: 62 66 69 6c 65 2e 64 62 5d 0a 20 20 20 20 3b 3b bfile.db]. ;;
2a20: 20 20 20 64 61 74 61 0a 20 20 20 20 28 6c 65 74 data. (let
2a30: 20 6c 6f 6f 70 20 28 28 73 74 61 74 65 20 27 73 loop ((state 's
2a40: 74 61 72 74 29 29 0a 20 20 20 20 20 20 28 6c 65 tart)). (le
2a50: 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 t-values (((inp
2a60: 6f 75 70 29 28 74 63 70 2d 61 63 63 65 70 74 20 oup)(tcp-accept
2a70: 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 29 29 29 serv-listener)))
2a80: 0a 09 28 6c 65 74 2a 20 28 28 63 6f 6e 74 72 6f ..(let* ((contro
2a90: 6c 64 61 74 20 28 72 65 61 64 20 69 6e 70 29 29 ldat (read inp))
2aa0: 0a 09 20 20 20 20 20 20 20 28 64 61 74 61 20 20 .. (data
2ab0: 20 20 20 20 20 28 72 65 61 64 20 69 6e 70 29 29 (read inp))
2ac0: 0a 09 20 20 20 20 20 20 20 28 72 65 73 70 20 20 .. (resp
2ad0: 20 20 20 20 20 28 75 6c 65 78 2d 68 61 6e 64 6c (ulex-handl
2ae0: 65 72 20 75 64 61 74 61 20 63 6f 6e 74 72 6f 6c er udata control
2af0: 64 61 74 20 64 61 74 61 29 29 29 0a 09 20 20 28 dat data))).. (
2b00: 69 66 20 72 65 73 70 20 28 77 72 69 74 65 20 72 if resp (write r
2b10: 65 73 70 20 6f 75 70 29 29 0a 09 20 20 28 63 6c esp oup)).. (cl
2b20: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 ose-input-port i
2b30: 6e 70 29 0a 09 20 20 28 63 6c 6f 73 65 2d 6f 75 np).. (close-ou
2b40: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 0a tput-port oup)).
2b50: 09 28 6c 6f 6f 70 20 73 74 61 74 65 29 29 29 29 .(loop state))))
2b60: 29 0a 0a 3b 3b 20 61 64 64 20 61 20 70 72 6f 63 )..;; add a proc
2b70: 20 74 6f 20 74 68 65 20 63 6d 64 20 6c 69 73 74 to the cmd list
2b80: 2c 20 74 68 65 73 65 20 61 72 65 20 64 6f 6e 65 , these are done
2b90: 20 73 79 6d 65 74 72 69 63 61 6c 6c 79 20 28 69 symetrically (i
2ba0: 2e 65 2e 20 69 6e 20 61 6c 6c 20 69 6e 73 74 61 .e. in all insta
2bb0: 6e 63 65 73 29 0a 3b 3b 20 73 6f 20 74 68 61 74 nces).;; so that
2bc0: 20 74 68 65 20 70 72 6f 63 20 63 61 6e 20 62 65 the proc can be
2bd0: 20 64 65 72 65 66 65 72 65 6e 63 65 64 20 72 65 dereferenced re
2be0: 6d 6f 74 65 6c 79 0a 3b 3b 0a 28 64 65 66 69 6e motely.;;.(defin
2bf0: 65 20 28 72 65 67 69 73 74 65 72 2d 63 6d 64 20 e (register-cmd
2c00: 75 64 61 74 61 20 6b 65 79 20 70 72 6f 63 29 0a udata key proc).
2c10: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
2c20: 74 21 20 28 75 64 61 74 2d 63 6d 64 73 20 75 64 t! (udat-cmds ud
2c30: 61 74 61 29 20 6b 65 79 20 70 72 6f 63 29 29 0a ata) key proc)).
2c40: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
2c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 77 6f 72 =========.;; wor
2c90: 6b 20 71 75 65 75 65 73 0a 3b 3b 3d 3d 3d 3d 3d k queues.;;=====
2ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ce0: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 61 64 64 2d =..(define (add-
2cf0: 74 6f 2d 77 6f 72 6b 2d 71 75 65 75 65 20 75 64 to-work-queue ud
2d00: 61 74 61 20 70 65 65 72 2d 64 61 74 20 63 6d 64 ata peer-dat cmd
2d10: 6b 65 79 20 71 72 79 6b 65 79 20 64 61 74 61 29 key qrykey data)
2d20: 0a 20 20 28 6c 65 74 20 28 28 77 64 61 74 20 28 . (let ((wdat (
2d30: 6d 61 6b 65 2d 77 6f 72 6b 20 70 65 65 72 2d 64 make-work peer-d
2d40: 61 74 3a 20 70 65 65 72 2d 64 61 74 20 63 6d 64 at: peer-dat cmd
2d50: 6b 65 79 3a 20 63 6d 64 6b 65 79 20 71 72 79 6b key: cmdkey qryk
2d60: 65 79 3a 20 71 72 79 6b 65 79 20 64 61 74 61 3a ey: qrykey data:
2d70: 20 64 61 74 61 29 29 29 0a 20 20 20 20 28 69 66 data))). (if
2d80: 20 28 75 64 61 74 2d 62 75 73 79 20 75 64 61 74 (udat-busy udat
2d90: 61 29 0a 09 28 71 75 65 75 65 2d 61 64 64 21 20 a)..(queue-add!
2da0: 28 75 64 61 74 2d 77 6f 72 6b 2d 71 75 65 75 65 (udat-work-queue
2db0: 20 75 64 61 74 61 29 20 77 64 61 74 29 0a 09 28 udata) wdat)..(
2dc0: 70 72 6f 63 65 73 73 2d 77 6f 72 6b 20 75 64 61 process-work uda
2dd0: 74 61 20 77 64 61 74 29 29 20 3b 3b 20 70 61 73 ta wdat)) ;; pas
2de0: 73 69 6e 67 20 69 6e 20 77 64 61 74 20 74 65 6c sing in wdat tel
2df0: 6c 73 20 70 72 6f 63 65 73 73 2d 77 6f 72 6b 20 ls process-work
2e00: 74 6f 20 66 69 72 73 74 20 70 72 6f 63 65 73 73 to first process
2e10: 20 74 68 65 20 70 61 73 73 65 64 20 69 6e 20 77 the passed in w
2e20: 64 61 74 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 dat. ))..(def
2e30: 69 6e 65 20 28 64 6f 2d 77 6f 72 6b 20 75 64 61 ine (do-work uda
2e40: 74 61 20 77 64 61 74 29 0a 20 20 23 66 29 0a 0a ta wdat). #f)..
2e50: 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 73 (define (process
2e60: 2d 77 6f 72 6b 20 75 64 61 74 61 20 23 21 6f 70 -work udata #!op
2e70: 74 69 6f 6e 61 6c 20 77 64 61 74 29 0a 20 20 28 tional wdat). (
2e80: 69 66 20 77 64 61 74 20 28 64 6f 2d 77 6f 72 6b if wdat (do-work
2e90: 20 75 64 61 74 61 20 77 64 61 74 29 29 20 3b 3b udata wdat)) ;;
2ea0: 20 70 72 6f 63 65 73 73 20 77 64 61 74 0a 20 20 process wdat.
2eb0: 28 6c 65 74 20 28 28 77 71 75 65 75 65 20 28 75 (let ((wqueue (u
2ec0: 64 61 74 2d 77 6f 72 6b 2d 71 75 65 75 65 20 75 dat-work-queue u
2ed0: 64 61 74 61 29 29 29 0a 20 20 20 20 28 69 66 20 data))). (if
2ee0: 28 6e 6f 74 20 28 71 75 65 75 65 2d 65 6d 70 74 (not (queue-empt
2ef0: 79 3f 20 77 71 75 65 75 65 29 29 0a 09 28 6c 65 y? wqueue))..(le
2f00: 74 20 6c 6f 6f 70 20 28 28 77 64 20 28 71 75 65 t loop ((wd (que
2f10: 75 65 2d 72 65 6d 6f 76 65 21 20 77 71 75 65 75 ue-remove! wqueu
2f20: 65 29 29 29 0a 09 20 20 28 64 6f 2d 77 6f 72 6b e))).. (do-work
2f30: 20 75 64 61 74 61 20 77 64 29 0a 09 20 20 28 69 udata wd).. (i
2f40: 66 20 28 6e 6f 74 20 28 71 75 65 75 65 2d 65 6d f (not (queue-em
2f50: 70 74 79 3f 20 77 71 75 65 75 65 29 29 0a 09 20 pty? wqueue))..
2f60: 20 20 20 20 20 28 6c 6f 6f 70 20 28 71 75 65 75 (loop (queu
2f70: 65 2d 72 65 6d 6f 76 65 21 20 77 71 75 65 75 65 e-remove! wqueue
2f80: 29 29 29 29 29 29 29 0a 0a 0a 0a 3b 3b 20 62 65 )))))))....;; be
2f90: 6c 6f 77 20 77 61 73 20 74 6f 20 65 6e 61 62 6c low was to enabl
2fa0: 65 20 72 65 2d 75 73 65 20 6f 66 20 63 6f 6e 6e e re-use of conn
2fb0: 65 63 74 69 6f 6e 73 2e 20 54 68 69 73 20 73 65 ections. This se
2fc0: 65 6d 73 20 6e 6f 6e 2d 74 72 69 76 69 61 6c 20 ems non-trivial
2fd0: 73 6f 20 66 6f 72 0a 3b 3b 20 6e 6f 77 20 6c 65 so for.;; now le
2fe0: 74 73 20 6f 70 65 6e 20 6f 6e 20 65 61 63 68 20 ts open on each
2ff0: 63 61 6c 6c 0a 3b 3b 0a 3b 3b 20 3b 3b 20 67 69 call.;;.;; ;; gi
3000: 76 65 6e 20 68 6f 73 74 2d 70 6f 72 74 20 67 65 ven host-port ge
3010: 74 20 6f 72 20 63 72 65 61 74 65 20 70 65 65 72 t or create peer
3020: 20 73 74 72 75 63 74 0a 3b 3b 20 3b 3b 0a 3b 3b struct.;; ;;.;;
3030: 20 28 64 65 66 69 6e 65 20 28 75 64 61 74 2d 67 (define (udat-g
3040: 65 74 2d 70 65 65 72 20 75 63 6f 6e 6e 20 68 6f et-peer uconn ho
3050: 73 74 2d 70 6f 72 74 29 0a 3b 3b 20 20 20 28 6f st-port).;; (o
3060: 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 r (hash-table-re
3070: 66 2f 64 65 66 61 75 6c 74 20 28 75 64 61 74 2d f/default (udat-
3080: 70 65 65 72 73 20 75 63 6f 6e 6e 29 20 68 6f 73 peers uconn) hos
3090: 74 2d 70 6f 72 74 20 23 66 29 0a 3b 3b 20 20 20 t-port #f).;;
30a0: 20 20 20 20 3b 3b 20 6e 6f 20 70 65 65 72 2c 20 ;; no peer,
30b0: 73 6f 20 63 72 65 61 74 65 20 70 64 61 74 20 61 so create pdat a
30c0: 6e 64 20 69 6e 69 74 20 69 74 0a 3b 3b 20 20 20 nd init it.;;
30d0: 20 20 20 20 0a 3b 3b 20 20 20 20 20 20 20 3b 3b .;; ;;
30e0: 20 4e 45 45 44 20 73 74 61 63 6b 20 6f 66 20 63 NEED stack of c
30f0: 6f 6e 6e 65 63 74 69 6f 6e 73 2c 20 70 6f 70 20 onnections, pop
3100: 61 6e 64 20 75 73 65 3b 20 69 6e 70 2c 20 6f 75 and use; inp, ou
3110: 70 2c 0a 3b 3b 20 20 20 20 20 20 20 3b 3b 20 63 p,.;; ;; c
3120: 72 65 61 74 69 6f 6e 5f 74 69 6d 65 20 28 72 65 reation_time (re
3130: 6d 6f 76 65 20 61 6e 64 20 63 72 65 61 74 65 20 move and create
3140: 6e 65 77 20 69 66 20 6f 76 65 72 20 32 34 68 72 new if over 24hr
3150: 73 20 6f 6c 64 0a 3b 3b 20 20 20 20 20 20 20 3b s old.;; ;
3160: 3b 20 0a 3b 3b 20 20 20 20 20 20 20 28 6c 65 74 ; .;; (let
3170: 20 28 28 70 64 61 74 20 28 6d 61 6b 65 2d 70 64 ((pdat (make-pd
3180: 61 74 20 68 6f 73 74 2d 70 6f 72 74 3a 20 68 6f at host-port: ho
3190: 73 74 2d 70 6f 72 74 29 29 29 0a 3b 3b 20 09 28 st-port))).;; .(
31a0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
31b0: 28 75 64 61 74 2d 70 65 65 72 73 20 75 63 6f 6e (udat-peers ucon
31c0: 6e 29 20 68 6f 73 74 2d 70 6f 72 74 20 70 64 61 n) host-port pda
31d0: 74 29 0a 3b 3b 20 09 70 64 61 74 29 29 29 0a 3b t).;; .pdat))).;
31e0: 3b 20 0a 3b 3b 20 3b 3b 20 69 73 20 70 63 6f 6e ; .;; ;; is pcon
31f0: 20 61 6c 69 76 65 0a 3b 3b 20 0a 3b 3b 20 3b 3b alive.;; .;; ;;
3200: 20 67 69 76 65 6e 20 68 6f 73 74 2d 70 6f 72 74 given host-port
3210: 20 61 6e 64 20 70 64 61 74 20 67 65 74 20 61 20 and pdat get a
3220: 70 63 6f 6e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 pcon.;; ;;.;; (d
3230: 65 66 69 6e 65 20 28 70 64 61 74 2d 67 65 74 2d efine (pdat-get-
3240: 70 63 6f 6e 20 70 64 61 74 20 68 6f 73 74 2d 70 pcon pdat host-p
3250: 6f 72 74 29 0a 3b 3b 20 20 20 28 6c 65 74 20 6c ort).;; (let l
3260: 6f 6f 70 20 28 28 63 6f 6e 6e 73 20 28 70 64 61 oop ((conns (pda
3270: 74 2d 63 6f 6e 6e 73 20 70 64 61 74 29 29 29 0a t-conns pdat))).
3280: 3b 3b 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ;; (if (null
3290: 3f 20 63 6f 6e 6e 73 29 20 3b 3b 20 6e 6f 6e 65 ? conns) ;; none
32a0: 3f 20 6d 61 6b 65 20 61 6e 64 20 72 65 74 75 72 ? make and retur
32b0: 6e 20 2d 20 64 6f 20 4e 4f 54 20 61 64 64 20 2d n - do NOT add -
32c0: 20 69 74 20 77 69 6c 6c 20 62 65 20 70 75 73 68 it will be push
32d0: 65 64 20 62 61 63 6b 20 6f 6e 20 6c 69 73 74 20 ed back on list
32e0: 6c 61 74 65 72 0a 3b 3b 20 09 28 69 6e 69 74 2d later.;; .(init-
32f0: 70 63 6f 6e 20 28 6d 61 6b 65 2d 70 63 6f 6e 29 pcon (make-pcon)
3300: 29 0a 3b 3b 20 09 28 6c 65 74 2a 20 28 28 63 6f ).;; .(let* ((co
3310: 6e 6e 20 28 70 6f 70 20 63 6f 6e 6e 73 29 29 29 nn (pop conns)))
3320: 0a 3b 3b 20 09 20 20 0a 3b 3b 20 3b 3b 20 67 69 .;; . .;; ;; gi
3330: 76 65 6e 20 68 6f 73 74 2d 70 6f 72 74 20 67 65 ven host-port ge
3340: 74 20 61 20 70 63 6f 6e 20 73 74 72 75 63 74 0a t a pcon struct.
3350: 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 ;; ;;.;; (define
3360: 20 28 75 64 61 74 2d 67 65 74 2d 70 63 6f 6e 20 (udat-get-pcon
3370: 0a 20 20 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d . .;;======
3380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33c0: 0a 3b 3b 20 6d 69 73 63 20 75 74 69 6c 73 0a 3b .;; misc utils.;
33d0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
33e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3410: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
3420: 20 28 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 75 63 (make-cookie uc
3430: 6f 6e 6e 29 0a 20 20 28 6c 65 74 20 28 28 6e 65 onn). (let ((ne
3440: 77 63 6e 75 6d 20 28 2b 20 28 75 64 61 74 2d 63 wcnum (+ (udat-c
3450: 6e 75 6d 20 75 63 6f 6e 6e 29 20 31 29 29 29 0a num uconn) 1))).
3460: 20 20 20 20 28 75 64 61 74 2d 63 6e 75 6d 2d 73 (udat-cnum-s
3470: 65 74 21 20 75 63 6f 6e 6e 20 6e 65 77 63 6e 75 et! uconn newcnu
3480: 6d 29 0a 20 20 20 20 28 63 6f 6e 63 20 28 75 64 m). (conc (ud
3490: 61 74 2d 6d 79 2d 61 64 64 72 65 73 73 20 75 63 at-my-address uc
34a0: 6f 6e 6e 29 20 22 3a 22 0a 09 20 20 28 75 64 61 onn) ":".. (uda
34b0: 74 2d 6d 79 2d 70 6f 72 74 20 20 20 20 75 63 6f t-my-port uco
34c0: 6e 6e 29 20 22 2d 22 0a 09 20 20 6e 65 77 63 6e nn) "-".. newcn
34d0: 75 6d 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d um)))..;;=======
34e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3520: 3b 3b 20 6e 65 74 77 6f 72 6b 20 75 74 69 6c 69 ;; network utili
3530: 74 69 65 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ties.;;=========
3540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
3580: 3b 20 4e 4f 54 45 3a 20 4c 6f 6f 6b 20 61 74 20 ; NOTE: Look at
3590: 61 64 64 72 65 73 73 2d 69 6e 66 6f 20 65 67 67 address-info egg
35a0: 20 61 73 20 61 6c 74 65 72 6e 61 74 69 76 65 20 as alternative
35b0: 74 6f 20 73 6f 6d 65 20 6f 66 20 74 68 69 73 0a to some of this.
35c0: 0a 28 64 65 66 69 6e 65 20 28 72 61 74 65 2d 69 .(define (rate-i
35d0: 70 20 69 70 61 64 64 72 29 0a 20 20 28 72 65 67 p ipaddr). (reg
35e0: 65 78 2d 63 61 73 65 20 69 70 61 64 64 72 0a 20 ex-case ipaddr.
35f0: 20 20 20 28 20 22 5e 31 32 37 5c 5c 2e 2e 2a 22 ( "^127\\..*"
3600: 20 5f 20 30 20 29 0a 20 20 20 20 28 20 22 5e 28 _ 0 ). ( "^(
3610: 31 30 5c 5c 2e 30 7c 31 39 32 5c 5c 2e 31 36 38 10\\.0|192\\.168
3620: 29 5c 5c 2e 2e 2a 22 20 5f 20 31 20 29 0a 20 20 )\\..*" _ 1 ).
3630: 20 20 28 20 65 6c 73 65 20 32 20 29 20 29 29 0a ( else 2 ) )).
3640: 0a 3b 3b 20 43 68 61 6e 67 65 20 74 68 69 73 20 .;; Change this
3650: 74 6f 20 62 69 61 73 20 66 6f 72 20 61 64 64 72 to bias for addr
3660: 65 73 73 65 73 20 77 69 74 68 20 61 20 72 65 61 esses with a rea
3670: 73 6f 6e 61 62 6c 65 20 62 72 6f 61 64 63 61 73 sonable broadcas
3680: 74 20 76 61 6c 75 65 3f 0a 3b 3b 0a 28 64 65 66 t value?.;;.(def
3690: 69 6e 65 20 28 69 70 2d 70 72 65 66 2d 6c 65 73 ine (ip-pref-les
36a0: 73 3f 20 61 20 62 29 0a 20 20 28 3e 20 28 72 61 s? a b). (> (ra
36b0: 74 65 2d 69 70 20 61 29 20 28 72 61 74 65 2d 69 te-ip a) (rate-i
36c0: 70 20 62 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 p b)))..(define
36d0: 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 (get-my-best-add
36e0: 72 65 73 73 29 0a 20 20 28 6c 65 74 20 28 28 61 ress). (let ((a
36f0: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 20 ll-my-addresses
3700: 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 29 29 0a (get-all-ips))).
3710: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 (cond. (
3720: 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 64 (null? all-my-ad
3730: 64 72 65 73 73 65 73 29 0a 20 20 20 20 20 20 28 dresses). (
3740: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 20 get-host-name))
3750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3770: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 69 ;; no i
3780: 6e 74 65 72 66 61 63 65 73 3f 0a 20 20 20 20 20 nterfaces?.
3790: 28 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 61 6c ((eq? (length al
37a0: 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 20 l-my-addresses)
37b0: 31 29 0a 20 20 20 20 20 20 28 63 61 72 20 61 6c 1). (car al
37c0: 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 29 l-my-addresses))
37d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37e0: 20 20 20 20 20 20 3b 3b 20 6f 6e 6c 79 20 6f 6e ;; only on
37f0: 65 20 74 6f 20 63 68 6f 6f 73 65 20 66 72 6f 6d e to choose from
3800: 2c 20 6a 75 73 74 20 67 6f 20 77 69 74 68 20 69 , just go with i
3810: 74 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 t. (else.
3820: 20 20 20 28 63 61 72 20 28 73 6f 72 74 20 61 6c (car (sort al
3830: 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 20 69 l-my-addresses i
3840: 70 2d 70 72 65 66 2d 6c 65 73 73 3f 29 29 29 29 p-pref-less?))))
3850: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 ))..(define (get
3860: 2d 61 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 29 -all-ips-sorted)
3870: 0a 20 20 28 73 6f 72 74 20 28 67 65 74 2d 61 6c . (sort (get-al
3880: 6c 2d 69 70 73 29 20 69 70 2d 70 72 65 66 2d 6c l-ips) ip-pref-l
3890: 65 73 73 3f 29 29 0a 0a 28 64 65 66 69 6e 65 20 ess?))..(define
38a0: 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 0a 20 20 (get-all-ips).
38b0: 28 6d 61 70 20 69 70 2d 3e 73 74 72 69 6e 67 20 (map ip->string
38c0: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 0a 09 (vector->list ..
38d0: 09 20 20 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 . (hostinfo-ad
38e0: 64 72 65 73 73 65 73 0a 09 09 20 20 20 20 28 68 dresses... (h
38f0: 6f 73 74 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 ost-information
3900: 28 63 75 72 72 65 6e 74 2d 68 6f 73 74 6e 61 6d (current-hostnam
3910: 65 29 29 29 29 29 29 0a 0a 29 0a e))))))..).