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 20 70 6f 73 69 78 20 63 68 scheme posix ch
0520: 69 63 6b 65 6e 20 64 61 74 61 2d 73 74 72 75 63 icken data-struc
0530: 74 75 72 65 73 20 70 6f 72 74 73 20 65 78 74 72 tures ports extr
0540: 61 73 20 66 69 6c 65 73 20 6d 61 69 6c 62 6f 78 as files mailbox
0550: 29 0a 28 69 6d 70 6f 72 74 20 73 72 66 69 2d 31 ).(import srfi-1
0560: 38 20 70 6b 74 73 20 6d 61 74 63 68 61 62 6c 65 8 pkts matchable
0570: 20 72 65 67 65 78 0a 09 74 79 70 65 64 2d 72 65 regex..typed-re
0580: 63 6f 72 64 73 20 73 72 66 69 2d 36 39 20 73 72 cords srfi-69 sr
0590: 66 69 2d 31 0a 09 73 72 66 69 2d 34 20 72 65 67 fi-1..srfi-4 reg
05a0: 65 78 2d 63 61 73 65 0a 09 28 70 72 65 66 69 78 ex-case..(prefix
05b0: 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 sqlite3 sqlite3
05c0: 3a 29 0a 09 66 6f 72 65 69 67 6e 0a 09 74 63 70 :)..foreign..tcp
05d0: 36 0a 09 3b 3b 20 75 6c 65 78 2d 6e 65 74 75 74 6..;; ulex-netut
05e0: 69 6c 0a 09 68 6f 73 74 69 6e 66 6f 0a 09 29 0a il..hostinfo..).
05f0: 0a 3b 3b 20 6d 61 6b 65 20 69 74 20 61 20 67 6c .;; make it a gl
0600: 6f 62 61 6c 3f 20 57 65 6c 6c 2c 20 69 74 20 69 obal? Well, it i
0610: 73 20 6c 6f 63 61 6c 20 74 6f 20 61 72 65 61 20 s local to area
0620: 6d 6f 64 75 6c 65 0a 0a 28 64 65 66 69 6e 65 20 module..(define
0630: 2a 63 61 70 74 61 69 6e 2d 70 6b 74 73 70 65 63 *captain-pktspec
0640: 2a 0a 20 20 60 28 28 63 61 70 74 61 69 6e 20 28 *. `((captain (
0650: 68 6f 73 74 20 20 20 20 20 2e 20 68 29 0a 09 20 host . h)..
0660: 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 2e 20 (port .
0670: 70 29 0a 09 20 20 20 20 20 28 70 69 64 20 20 20 p).. (pid
0680: 20 20 20 2e 20 69 29 0a 09 20 20 20 20 20 28 69 . i).. (i
0690: 70 61 64 64 72 20 20 20 2e 20 61 29 0a 09 20 20 paddr . a)..
06a0: 20 20 20 29 0a 20 20 20 20 23 3b 28 64 61 74 61 ). #;(data
06b0: 20 20 20 28 68 6f 73 74 6e 61 6d 65 20 2e 20 68 (hostname . h
06c0: 29 20 20 3b 3b 20 73 65 6e 64 65 72 20 68 6f 73 ) ;; sender hos
06d0: 74 6e 61 6d 65 0a 09 20 20 20 20 28 70 6f 72 74 tname.. (port
06e0: 20 20 20 20 20 2e 20 70 29 20 20 3b 3b 20 73 65 . p) ;; se
06f0: 6e 64 65 72 20 70 6f 72 74 0a 09 20 20 20 20 28 nder port.. (
0700: 69 70 61 64 64 72 20 20 20 2e 20 61 29 20 20 3b ipaddr . a) ;
0710: 3b 20 73 65 6e 64 65 72 20 69 70 0a 09 20 20 20 ; sender ip..
0720: 20 28 68 6f 73 74 6b 65 79 20 20 2e 20 6b 29 20 (hostkey . k)
0730: 20 3b 3b 20 73 65 6e 64 69 6e 67 20 68 6f 73 74 ;; sending host
0740: 20 6b 65 79 20 2d 20 73 74 6f 72 65 20 69 6e 66 key - store inf
0750: 6f 20 61 74 20 73 65 72 76 65 72 20 75 6e 64 65 o at server unde
0760: 72 20 74 68 69 73 20 6b 65 79 0a 09 20 20 20 20 r this key..
0770: 28 73 65 72 76 6b 65 79 20 20 2e 20 73 29 20 20 (servkey . s)
0780: 3b 3b 20 73 65 72 76 65 72 20 6b 65 79 20 2d 20 ;; server key -
0790: 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 6d 61 this needs to ma
07a0: 74 63 68 20 61 74 20 73 65 72 76 65 72 20 65 6e tch at server en
07b0: 64 20 6f 72 20 72 65 6a 65 63 74 20 74 68 65 20 d or reject the
07c0: 6d 73 67 0a 09 20 20 20 20 28 66 6f 72 6d 61 74 msg.. (format
07d0: 20 20 20 2e 20 66 29 20 20 3b 3b 20 73 62 3d 73 . f) ;; sb=s
07e0: 65 72 69 61 6c 69 7a 65 64 2d 62 61 73 65 36 34 erialized-base64
07f0: 2c 20 74 3d 74 65 78 74 2c 20 73 78 3d 73 65 78 , t=text, sx=sex
0800: 70 72 2c 20 6a 3d 6a 73 6f 6e 0a 09 20 20 20 20 pr, j=json..
0810: 28 64 61 74 61 20 20 20 20 20 2e 20 64 29 20 20 (data . d)
0820: 3b 3b 20 62 61 73 65 36 34 20 65 6e 63 6f 64 65 ;; base64 encode
0830: 64 20 73 6c 6c 6e 20 64 61 74 61 0a 09 20 20 20 d slln data..
0840: 20 29 29 29 0a 0a 3b 3b 20 73 74 72 75 63 74 20 )))..;; struct
0850: 66 6f 72 20 6b 65 65 70 69 6e 67 20 74 72 61 63 for keeping trac
0860: 6b 20 6f 66 20 6f 75 72 20 77 6f 72 6c 64 0a 0a k of our world..
0870: 28 64 65 66 73 74 72 75 63 74 20 75 64 61 74 0a (defstruct udat.
0880: 20 20 3b 3b 20 63 61 70 74 61 69 6e 20 69 6e 66 ;; captain inf
0890: 6f 0a 20 20 28 63 61 70 74 61 69 6e 2d 61 64 64 o. (captain-add
08a0: 72 65 73 73 20 23 66 29 0a 20 20 28 63 61 70 74 ress #f). (capt
08b0: 61 69 6e 2d 68 6f 73 74 20 20 20 20 23 66 29 0a ain-host #f).
08c0: 20 20 28 63 61 70 74 61 69 6e 2d 70 6f 72 74 20 (captain-port
08d0: 20 20 20 23 66 29 0a 20 20 28 63 61 70 74 61 69 #f). (captai
08e0: 6e 2d 70 69 64 20 20 20 20 20 23 66 29 0a 20 20 n-pid #f).
08f0: 28 63 61 70 74 61 69 6e 2d 6c 65 61 73 65 20 20 (captain-lease
0900: 20 30 29 20 20 20 20 3b 3b 20 74 69 6d 65 20 28 0) ;; time (
0910: 75 6e 69 78 20 65 70 6f 63 29 20 73 65 63 6f 6e unix epoc) secon
0920: 64 73 20 77 68 65 6e 20 74 68 65 20 6c 65 61 73 ds when the leas
0930: 65 20 69 73 20 75 70 0a 20 20 28 75 6c 65 78 2d e is up. (ulex-
0940: 64 69 72 20 20 20 20 20 20 20 20 28 63 6f 6e 63 dir (conc
0950: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
0960: 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 t-variable "HOME
0970: 22 29 20 22 2f 2e 75 6c 65 78 22 29 29 0a 20 20 ") "/.ulex")).
0980: 28 63 70 6b 74 73 2d 64 69 72 20 20 20 20 20 20 (cpkts-dir
0990: 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 (conc (get-envi
09a0: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
09b0: 20 22 48 4f 4d 45 22 29 20 22 2f 2e 75 6c 65 78 "HOME") "/.ulex
09c0: 2f 70 6b 74 73 22 29 29 0a 20 20 28 63 70 6b 74 /pkts")). (cpkt
09d0: 2d 73 70 65 63 20 20 20 20 20 20 20 2a 63 61 70 -spec *cap
09e0: 74 61 69 6e 2d 70 6b 74 73 70 65 63 2a 29 0a 20 tain-pktspec*).
09f0: 20 3b 3b 20 74 68 69 73 20 70 72 6f 63 65 73 73 ;; this process
0a00: 65 73 20 69 6e 66 6f 0a 20 20 28 6d 79 2d 63 70 es info. (my-cp
0a10: 6b 74 2d 6b 65 79 20 20 20 20 20 23 66 29 20 20 kt-key #f)
0a20: 20 3b 3b 20 70 75 74 20 5a 20 63 61 72 64 20 68 ;; put Z card h
0a30: 65 72 65 20 77 68 65 6e 20 49 20 63 72 65 61 74 ere when I creat
0a40: 65 20 61 20 70 6b 74 20 66 6f 72 20 6d 79 73 65 e a pkt for myse
0a50: 6c 66 20 61 73 20 63 61 70 74 61 69 6e 0a 20 20 lf as captain.
0a60: 28 6d 79 2d 61 64 64 72 65 73 73 20 20 20 20 20 (my-address
0a70: 20 23 66 29 0a 20 20 28 6d 79 2d 68 6f 73 74 6e #f). (my-hostn
0a80: 61 6d 65 20 20 20 20 20 23 66 29 0a 20 20 28 6d ame #f). (m
0a90: 79 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 23 y-port #
0aa0: 66 29 0a 20 20 28 6d 79 2d 70 69 64 20 20 20 20 f). (my-pid
0ab0: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 70 (current-p
0ac0: 72 6f 63 65 73 73 2d 69 64 29 29 0a 20 20 28 6d rocess-id)). (m
0ad0: 79 2d 64 62 73 20 20 20 20 20 20 20 20 20 20 27 y-dbs '
0ae0: 28 29 29 0a 20 20 3b 3b 20 73 65 72 76 65 72 20 ()). ;; server
0af0: 61 6e 64 20 68 61 6e 64 6c 65 72 20 74 68 72 65 and handler thre
0b00: 61 64 0a 20 20 28 73 65 72 76 2d 6c 69 73 74 65 ad. (serv-liste
0b10: 6e 65 72 20 20 20 23 66 29 20 20 20 20 20 20 20 ner #f)
0b20: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 69 ;; thi
0b30: 73 20 70 72 6f 63 65 73 73 65 73 20 73 65 72 76 s processes serv
0b40: 65 72 20 69 6e 66 6f 0a 20 20 28 68 61 6e 64 6c er info. (handl
0b50: 65 72 2d 74 68 72 65 61 64 20 20 23 66 29 0a 20 er-thread #f).
0b60: 20 28 6d 62 6f 78 65 73 20 20 20 20 20 20 20 20 (mboxes
0b70: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
0b80: 6c 65 29 29 20 20 3b 3b 20 6b 65 79 20 3d 3e 20 le)) ;; key =>
0b90: 6d 62 6f 78 0a 20 20 3b 3b 20 6f 74 68 65 72 20 mbox. ;; other
0ba0: 73 65 72 76 65 72 73 0a 20 20 28 70 65 65 72 73 servers. (peers
0bb0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
0bc0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 20 3b -hash-table)) ;
0bd0: 3b 20 68 6f 73 74 2d 70 6f 72 74 20 3d 3e 20 70 ; host-port => p
0be0: 65 65 72 20 72 65 63 6f 72 64 0a 20 20 28 64 62 eer record. (db
0bf0: 6f 77 6e 65 72 73 20 20 20 20 20 20 20 20 28 6d owners (m
0c00: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
0c10: 20 20 3b 3b 20 64 62 66 69 6c 65 20 3d 3e 20 68 ;; dbfile => h
0c20: 6f 73 74 2d 70 6f 72 74 0a 20 20 28 68 61 6e 64 ost-port. (hand
0c30: 6c 65 72 73 20 20 20 20 20 20 20 20 28 6d 61 6b lers (mak
0c40: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 20 e-hash-table))
0c50: 3b 3b 20 64 62 66 69 6c 65 20 3d 3e 20 70 72 6f ;; dbfile => pro
0c60: 63 0a 20 20 3b 3b 20 28 6f 75 74 67 6f 69 6e 67 c. ;; (outgoing
0c70: 2d 63 6f 6e 6e 73 20 20 28 6d 61 6b 65 2d 68 61 -conns (make-ha
0c80: 73 68 2d 74 61 62 6c 65 29 29 20 20 3b 3b 20 68 sh-table)) ;; h
0c90: 6f 73 74 3a 70 6f 72 74 20 2d 3e 20 63 6f 6e 6e ost:port -> conn
0ca0: 0a 20 20 28 77 6f 72 6b 2d 71 75 65 75 65 20 20 . (work-queue
0cb0: 20 20 20 20 28 6d 61 6b 65 2d 71 75 65 75 65 29 (make-queue)
0cc0: 29 20 20 20 20 20 20 20 3b 3b 20 6d 6f 73 74 20 ) ;; most
0cd0: 73 74 75 66 66 20 67 6f 65 73 20 68 65 72 65 0a stuff goes here.
0ce0: 20 20 3b 3b 20 28 66 61 73 74 2d 71 75 65 75 65 ;; (fast-queue
0cf0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 71 75 65 75 (make-queu
0d00: 65 29 29 20 20 20 20 20 20 20 3b 3b 20 73 75 70 e)) ;; sup
0d10: 65 72 20 71 75 69 63 6b 20 73 74 75 66 66 20 67 er quick stuff g
0d20: 6f 65 73 20 68 65 72 65 20 28 65 2e 67 2e 20 70 oes here (e.g. p
0d30: 69 6e 67 29 0a 20 20 28 62 75 73 79 20 20 20 20 ing). (busy
0d40: 20 20 20 20 20 20 20 20 23 66 29 20 20 20 20 20 #f)
0d50: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 ;; i
0d60: 73 20 65 69 74 68 65 72 20 6f 66 20 74 68 65 20 s either of the
0d70: 71 75 65 75 65 73 20 62 75 73 79 2c 20 75 73 65 queues busy, use
0d80: 20 74 6f 20 73 77 69 74 63 68 20 62 65 74 77 65 to switch betwe
0d90: 65 6e 20 71 75 65 75 69 6e 67 20 74 61 73 6b 73 en queuing tasks
0da0: 20 6f 72 20 64 6f 69 6e 67 20 69 6d 6d 65 64 69 or doing immedi
0db0: 61 74 65 6c 79 0a 20 20 3b 3b 20 61 70 70 20 69 ately. ;; app i
0dc0: 6e 66 6f 0a 20 20 28 61 70 70 6e 61 6d 65 20 20 nfo. (appname
0dd0: 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 64 62 #f). (db
0de0: 74 79 70 65 73 20 20 20 20 20 20 20 20 20 28 6d types (m
0df0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
0e00: 20 20 3b 3b 20 74 68 69 73 20 73 68 6f 75 6c 64 ;; this should
0e10: 20 62 65 20 61 6e 20 61 6c 69 73 74 20 62 75 74 be an alist but
0e20: 20 68 61 73 68 20 69 73 20 65 61 73 69 65 72 2e hash is easier.
0e30: 20 64 62 74 79 70 65 20 3d 3e 20 5b 20 69 6e 69 dbtype => [ ini
0e40: 74 70 72 6f 63 20 73 79 6e 63 70 72 6f 63 20 5d tproc syncproc ]
0e50: 0a 20 20 3b 3b 20 63 6f 6f 6b 69 65 73 0a 20 20 . ;; cookies.
0e60: 28 63 6e 75 6d 20 20 20 20 20 20 20 20 20 20 20 (cnum
0e70: 20 30 29 20 3b 3b 20 63 6f 6f 6b 69 65 20 6e 75 0) ;; cookie nu
0e80: 6d 0a 20 20 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d m. )..;;=======
0e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
0ed0: 3b 3b 20 4e 45 57 20 41 50 50 52 4f 41 43 48 0a ;; NEW APPROACH.
0ee0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f20: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 20 73 74 ========..;; st
0f30: 61 72 74 2d 73 65 72 76 65 72 2d 66 69 6e 64 2d art-server-find-
0f40: 70 6f 72 74 20 20 3b 3b 20 67 6f 74 74 61 20 68 port ;; gotta h
0f50: 61 76 65 20 61 20 73 65 72 76 65 72 20 70 6f 72 ave a server por
0f60: 74 20 72 65 61 64 79 20 66 72 6f 6d 20 74 68 65 t ready from the
0f70: 20 76 65 72 79 20 62 65 67 69 6e 69 6e 67 0a 0a very begining..
0f80: 3b 3b 20 75 64 61 74 61 20 20 20 20 2d 20 61 6c ;; udata - al
0f90: 6c 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e l the connection
0fa0: 20 69 6e 66 6f 2c 20 63 61 70 74 61 69 6e 2c 20 info, captain,
0fb0: 73 65 72 76 65 72 2c 20 75 6c 65 78 20 64 62 20 server, ulex db
0fc0: 65 74 63 2e 20 4d 55 53 54 20 42 45 20 50 41 53 etc. MUST BE PAS
0fd0: 53 45 44 20 49 4e 0a 3b 3b 20 64 62 70 61 74 68 SED IN.;; dbpath
0fe0: 20 20 20 2d 20 66 75 6c 6c 20 70 61 74 68 20 61 - full path a
0ff0: 6e 64 20 66 69 6c 65 6e 61 6d 65 20 6f 66 20 74 nd filename of t
1000: 68 65 20 64 62 20 74 6f 20 74 61 6c 6b 20 74 6f he db to talk to
1010: 20 6f 72 20 61 20 73 79 6d 62 6f 6c 20 6e 61 6d or a symbol nam
1020: 69 6e 67 20 74 68 65 20 64 62 3f 0a 3b 3b 20 63 ing the db?.;; c
1030: 61 6c 6c 6e 61 6d 65 20 2d 20 74 68 65 20 72 65 allname - the re
1040: 6d 6f 74 65 20 63 61 6c 6c 20 74 6f 20 65 78 65 mote call to exe
1050: 63 75 74 65 0a 3b 3b 20 70 61 72 61 6d 73 20 20 cute.;; params
1060: 20 2d 20 70 61 72 61 6d 65 74 65 72 73 20 74 6f - parameters to
1070: 20 70 61 73 73 20 74 6f 20 74 68 65 20 72 65 6d pass to the rem
1080: 6f 74 65 20 63 61 6c 6c 0a 3b 3b 0a 28 64 65 66 ote call.;;.(def
1090: 69 6e 65 20 28 72 65 6d 6f 74 65 2d 63 61 6c 6c ine (remote-call
10a0: 20 75 64 61 74 61 20 64 62 70 61 74 68 20 64 62 udata dbpath db
10b0: 74 79 70 65 20 63 61 6c 6c 6e 61 6d 65 20 2e 20 type callname .
10c0: 70 61 72 61 6d 73 29 0a 20 20 28 73 74 61 72 74 params). (start
10d0: 2d 73 65 72 76 65 72 2d 66 69 6e 64 2d 70 6f 72 -server-find-por
10e0: 74 20 75 64 61 74 61 29 20 3b 3b 20 65 6e 73 75 t udata) ;; ensu
10f0: 72 65 20 77 65 20 68 61 76 65 20 61 20 6c 6f 63 re we have a loc
1100: 61 6c 20 73 65 72 76 65 72 0a 20 20 28 66 69 6e al server. (fin
1110: 64 2d 6f 72 2d 73 65 74 75 70 2d 63 61 70 74 61 d-or-setup-capta
1120: 69 6e 20 75 64 61 74 61 29 0a 20 20 3b 3b 20 6c in udata). ;; l
1130: 6f 6f 6b 20 61 74 20 63 6f 6e 6e 65 63 74 2c 20 ook at connect,
1140: 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2c process-request,
1150: 20 73 65 6e 64 2c 20 73 65 6e 64 2d 72 65 63 65 send, send-rece
1160: 69 76 65 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 ive. (let-value
1170: 73 20 28 28 28 63 6f 6f 6b 69 65 2d 6b 65 79 20 s (((cookie-key
1180: 68 6f 73 74 2d 70 6f 72 74 29 28 67 65 74 2d 64 host-port)(get-d
1190: 62 2d 6f 77 6e 65 72 20 75 64 61 74 61 20 64 62 b-owner udata db
11a0: 70 61 74 68 20 64 62 74 79 70 65 29 29 29 0a 20 path dbtype))).
11b0: 20 20 20 28 73 65 6e 64 2d 72 65 63 65 69 76 65 (send-receive
11c0: 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 udata host-port
11d0: 20 63 61 6c 6c 6e 61 6d 65 20 63 6f 6f 6b 69 65 callname cookie
11e0: 2d 6b 65 79 20 70 61 72 61 6d 73 29 29 29 0a 0a -key params)))..
11f0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
1200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1230: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4b 45 59 20 ========.;; KEY
1240: 46 55 4e 43 54 49 4f 4e 53 20 2d 20 54 48 45 53 FUNCTIONS - THES
1250: 45 20 41 52 45 20 54 4f 4f 20 42 45 20 45 58 50 E ARE TOO BE EXP
1260: 4f 53 45 44 20 41 4e 44 20 55 53 45 44 0a 3b 3b OSED AND USED.;;
1270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12b0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 6e 65 ======..;; conne
12c0: 63 74 69 6f 6e 20 73 65 74 75 70 20 61 6e 64 20 ction setup and
12d0: 6d 61 6e 61 67 65 6d 65 6e 74 20 66 75 6e 63 74 management funct
12e0: 69 6f 6e 73 0a 0a 3b 3b 20 54 68 69 73 20 69 73 ions..;; This is
12f0: 20 74 68 65 20 62 61 73 69 63 20 73 65 74 75 70 the basic setup
1300: 20 63 6f 6d 6d 61 6e 64 2e 20 4d 75 73 74 20 61 command. Must a
1310: 6c 77 61 79 73 20 62 65 0a 3b 3b 20 63 61 6c 6c lways be.;; call
1320: 65 64 20 62 65 66 6f 72 65 20 63 6f 6e 6e 65 63 ed before connec
1330: 74 69 6e 67 20 74 6f 20 61 20 64 62 20 75 73 69 ting to a db usi
1340: 6e 67 20 63 6f 6e 6e 65 63 74 2e 0a 3b 3b 0a 3b ng connect..;;.;
1350: 3b 20 66 69 6e 64 20 6f 72 20 62 65 63 6f 6d 65 ; find or become
1360: 20 74 68 65 20 63 61 70 74 61 69 6e 0a 3b 3b 20 the captain.;;
1370: 73 65 74 75 70 20 61 6e 64 20 72 65 74 75 72 6e setup and return
1380: 20 61 20 75 6c 65 78 20 6f 62 6a 65 63 74 0a 3b a ulex object.;
1390: 3b 0a 28 64 65 66 69 6e 65 20 28 66 69 6e 64 2d ;.(define (find-
13a0: 6f 72 2d 73 65 74 75 70 2d 63 61 70 74 61 69 6e or-setup-captain
13b0: 20 75 64 61 74 61 29 0a 20 20 3b 3b 20 73 65 65 udata). ;; see
13c0: 20 69 66 20 77 65 20 61 6c 72 65 61 64 79 20 68 if we already h
13d0: 61 76 65 20 61 20 63 61 70 74 61 69 6e 20 61 6e ave a captain an
13e0: 64 20 69 66 20 74 68 65 20 6c 65 61 73 65 20 69 d if the lease i
13f0: 73 20 6f 6b 0a 20 20 28 69 66 20 28 61 6e 64 20 s ok. (if (and
1400: 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 61 64 (udat-captain-ad
1410: 64 72 65 73 73 20 75 64 61 74 61 29 0a 09 20 20 dress udata)..
1420: 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 70 (udat-captain-p
1430: 6f 72 74 20 20 20 20 75 64 61 74 61 29 0a 09 20 ort udata)..
1440: 20 20 28 3c 20 28 63 75 72 72 65 6e 74 2d 73 65 (< (current-se
1450: 63 6f 6e 64 73 29 20 28 75 64 61 74 2d 63 61 70 conds) (udat-cap
1460: 74 61 69 6e 2d 6c 65 61 73 65 20 75 64 61 74 61 tain-lease udata
1470: 29 29 29 0a 20 20 20 20 20 20 75 64 61 74 61 0a ))). udata.
1480: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 63 70 (let* ((cp
1490: 6b 74 73 20 28 67 65 74 2d 61 6c 6c 2d 63 61 70 kts (get-all-cap
14a0: 74 61 69 6e 2d 70 6b 74 73 20 75 64 61 74 61 29 tain-pkts udata)
14b0: 29 20 3b 3b 20 72 65 61 64 20 63 61 70 74 61 69 ) ;; read captai
14c0: 6e 20 70 6b 74 73 0a 09 20 20 20 20 20 28 63 61 n pkts.. (ca
14d0: 70 74 6e 20 28 67 65 74 2d 77 69 6e 6e 69 6e 67 ptn (get-winning
14e0: 2d 70 6b 74 20 63 70 6b 74 73 29 29 29 0a 09 28 -pkt cpkts)))..(
14f0: 69 66 20 63 61 70 74 6e 0a 09 20 20 20 20 28 6c if captn.. (l
1500: 65 74 2a 20 28 28 70 6f 72 74 20 20 20 28 61 6c et* ((port (al
1510: 69 73 74 2d 72 65 66 20 27 70 6f 72 74 20 20 20 ist-ref 'port
1520: 63 61 70 74 6e 29 29 0a 09 09 20 20 20 28 68 6f captn))... (ho
1530: 73 74 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 st (alist-ref
1540: 27 68 6f 73 74 20 20 20 63 61 70 74 6e 29 29 0a 'host captn)).
1550: 09 09 20 20 20 28 69 70 61 64 64 72 20 28 61 6c .. (ipaddr (al
1560: 69 73 74 2d 72 65 66 20 27 69 70 61 64 64 72 20 ist-ref 'ipaddr
1570: 63 61 70 74 6e 29 29 0a 09 09 20 20 20 28 70 69 captn))... (pi
1580: 64 20 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 d (alist-ref
1590: 27 70 69 64 20 20 20 20 63 61 70 74 6e 29 29 0a 'pid captn)).
15a0: 09 09 20 20 20 28 5a 20 20 20 20 20 20 28 61 6c .. (Z (al
15b0: 69 73 74 2d 72 65 66 20 27 5a 20 20 20 20 20 20 ist-ref 'Z
15c0: 63 61 70 74 6e 29 29 29 0a 09 20 20 20 20 20 20 captn)))..
15d0: 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 61 64 (udat-captain-ad
15e0: 64 72 65 73 73 2d 73 65 74 21 20 75 64 61 74 61 dress-set! udata
15f0: 20 69 70 61 64 64 72 29 0a 09 20 20 20 20 20 20 ipaddr)..
1600: 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 68 6f (udat-captain-ho
1610: 73 74 2d 73 65 74 21 20 20 20 20 75 64 61 74 61 st-set! udata
1620: 20 68 6f 73 74 29 0a 09 20 20 20 20 20 20 28 75 host).. (u
1630: 64 61 74 2d 63 61 70 74 61 69 6e 2d 70 6f 72 74 dat-captain-port
1640: 2d 73 65 74 21 20 20 20 20 75 64 61 74 61 20 70 -set! udata p
1650: 6f 72 74 29 0a 09 20 20 20 20 20 20 28 75 64 61 ort).. (uda
1660: 74 2d 63 61 70 74 61 69 6e 2d 70 69 64 2d 73 65 t-captain-pid-se
1670: 74 21 20 20 20 20 20 75 64 61 74 61 20 70 69 64 t! udata pid
1680: 29 0a 09 20 20 20 20 20 20 28 75 64 61 74 2d 63 ).. (udat-c
1690: 61 70 74 61 69 6e 2d 6c 65 61 73 65 2d 73 65 74 aptain-lease-set
16a0: 21 20 20 20 75 64 61 74 61 20 28 2b 20 28 63 75 ! udata (+ (cu
16b0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 31 rrent-seconds) 1
16c0: 30 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2d 0)).. (let-
16d0: 76 61 6c 75 65 73 20 28 28 28 73 75 63 63 65 73 values (((succes
16e0: 73 20 70 69 6e 67 74 69 6d 65 29 28 70 69 6e 67 s pingtime)(ping
16f0: 20 75 64 61 74 61 20 28 63 6f 6e 63 20 69 70 61 udata (conc ipa
1700: 64 64 72 20 22 3a 22 20 70 6f 72 74 29 29 29 29 ddr ":" port))))
1710: 0a 09 09 28 69 66 20 73 75 63 63 65 73 73 0a 09 ...(if success..
1720: 09 20 20 20 20 75 64 61 74 61 0a 09 09 20 20 20 . udata...
1730: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
1740: 28 70 72 69 6e 74 20 22 46 6f 75 6e 64 20 75 6e (print "Found un
1750: 72 65 61 63 68 61 62 6c 65 20 63 61 70 74 61 69 reachable captai
1760: 6e 20 61 74 20 22 20 69 70 61 64 64 72 20 22 3a n at " ipaddr ":
1770: 22 20 70 6f 72 74 20 22 2c 20 72 65 6d 6f 76 69 " port ", removi
1780: 6e 67 20 70 6b 74 22 29 0a 09 09 20 20 20 20 20 ng pkt")...
1790: 20 28 72 65 6d 6f 76 65 2d 63 61 70 74 61 69 6e (remove-captain
17a0: 2d 70 6b 74 20 75 64 61 74 61 20 63 61 70 74 6e -pkt udata captn
17b0: 29 0a 09 09 20 20 20 20 20 20 28 66 69 6e 64 2d )... (find-
17c0: 6f 72 2d 73 65 74 75 70 2d 63 61 70 74 61 69 6e or-setup-captain
17d0: 20 75 64 61 74 61 29 29 29 29 0a 09 20 20 20 20 udata))))..
17e0: 20 20 28 62 65 67 69 6e 0a 09 09 28 73 65 74 75 (begin...(setu
17f0: 70 2d 61 73 2d 63 61 70 74 61 69 6e 20 75 64 61 p-as-captain uda
1800: 74 61 29 20 20 3b 3b 20 74 68 69 73 20 73 61 76 ta) ;; this sav
1810: 65 73 20 74 68 65 20 74 68 72 65 61 64 20 74 6f es the thread to
1820: 20 63 61 70 74 61 69 6e 2d 74 68 72 65 61 64 20 captain-thread
1830: 61 6e 64 20 73 74 61 72 74 73 20 74 68 65 20 74 and starts the t
1840: 68 72 65 61 64 0a 09 09 28 66 69 6e 64 2d 6f 72 hread...(find-or
1850: 2d 73 65 74 75 70 2d 63 61 70 74 61 69 6e 20 75 -setup-captain u
1860: 64 61 74 61 29 29 29 29 29 29 29 0a 0a 3b 3b 20 data)))))))..;;
1870: 63 6f 6e 6e 65 63 74 20 74 6f 20 61 20 73 70 65 connect to a spe
1880: 63 69 66 69 63 20 64 62 66 69 6c 65 0a 3b 3b 20 cific dbfile.;;
1890: 20 20 2d 20 69 66 20 61 6c 72 65 61 64 79 20 63 - if already c
18a0: 6f 6e 6e 65 63 74 65 64 20 2d 20 72 65 74 75 72 onnected - retur
18b0: 6e 20 74 68 65 20 64 62 6f 77 6e 65 72 20 68 6f n the dbowner ho
18c0: 73 74 2d 70 6f 72 74 0a 3b 3b 20 20 20 2d 20 61 st-port.;; - a
18d0: 73 6b 20 74 68 65 20 63 61 70 74 61 69 6e 20 77 sk the captain w
18e0: 68 6f 20 74 6f 20 74 61 6c 6b 20 74 6f 20 66 6f ho to talk to fo
18f0: 72 20 74 68 69 73 20 64 62 0a 3b 3b 20 20 20 2d r this db.;; -
1900: 20 70 75 74 20 74 68 65 20 65 6e 74 72 79 20 69 put the entry i
1910: 6e 20 74 68 65 20 64 62 6f 77 6e 65 72 73 20 68 n the dbowners h
1920: 61 73 68 20 61 73 20 64 62 66 69 6c 65 20 3d 3e ash as dbfile =>
1930: 20 68 6f 73 74 2d 70 6f 72 74 0a 3b 3b 0a 28 64 host-port.;;.(d
1940: 65 66 69 6e 65 20 28 63 6f 6e 6e 65 63 74 20 75 efine (connect u
1950: 64 61 74 61 20 64 62 66 6e 61 6d 65 20 64 62 74 data dbfname dbt
1960: 79 70 65 29 0a 20 20 28 6f 72 20 28 68 61 73 68 ype). (or (hash
1970: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
1980: 6c 74 20 28 75 64 61 74 2d 64 62 6f 77 6e 65 72 lt (udat-dbowner
1990: 73 20 75 64 61 74 61 29 20 64 62 66 6e 61 6d 65 s udata) dbfname
19a0: 20 23 66 29 0a 20 20 20 20 20 20 28 6c 65 74 2d #f). (let-
19b0: 76 61 6c 75 65 73 20 28 28 28 73 75 63 63 65 73 values (((succes
19c0: 73 20 64 62 6f 77 6e 65 72 2d 68 6f 73 74 2d 70 s dbowner-host-p
19d0: 6f 72 74 29 28 67 65 74 2d 64 62 2d 6f 77 6e 65 ort)(get-db-owne
19e0: 72 20 75 64 61 74 61 20 64 62 66 6e 61 6d 65 20 r udata dbfname
19f0: 64 62 74 79 70 65 29 29 29 0a 09 28 69 66 20 73 dbtype)))..(if s
1a00: 75 63 63 65 73 73 0a 09 20 20 20 20 28 62 65 67 uccess.. (beg
1a10: 69 6e 0a 09 20 20 20 20 20 20 3b 3b 20 6a 75 73 in.. ;; jus
1a20: 74 20 63 6c 6f 62 62 65 72 20 74 68 65 20 72 65 t clobber the re
1a30: 63 6f 72 64 2c 20 74 68 69 73 20 69 73 20 74 68 cord, this is th
1a40: 65 20 6e 65 77 20 64 61 74 61 20 6e 6f 20 6d 61 e new data no ma
1a50: 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 20 tter what..
1a60: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
1a70: 21 20 28 75 64 61 74 2d 64 62 6f 77 6e 65 72 73 ! (udat-dbowners
1a80: 20 75 64 61 74 61 29 20 64 62 66 6e 61 6d 65 20 udata) dbfname
1a90: 64 62 6f 77 6e 65 72 2d 68 6f 73 74 2d 70 6f 72 dbowner-host-por
1aa0: 74 29 0a 09 20 20 20 20 20 20 64 62 6f 77 6e 65 t).. dbowne
1ab0: 72 2d 68 6f 73 74 2d 70 6f 72 74 29 0a 09 20 20 r-host-port)..
1ac0: 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 72 65 74 #f))))..;; ret
1ad0: 75 72 6e 73 3a 20 73 75 63 63 65 73 73 20 70 69 urns: success pi
1ae0: 6e 67 74 69 6d 65 0a 3b 3b 0a 3b 3b 20 4e 4f 54 ngtime.;;.;; NOT
1af0: 45 3a 20 63 61 75 73 65 73 20 74 68 65 20 63 61 E: causes the ca
1b00: 6c 6c 65 65 20 74 6f 20 73 74 6f 72 65 20 74 68 llee to store th
1b10: 65 20 69 6e 66 6f 20 6f 6e 20 74 68 69 73 20 68 e info on this h
1b20: 6f 73 74 20 61 6c 6f 6e 67 20 77 69 74 68 20 74 ost along with t
1b30: 68 65 20 64 62 73 20 74 68 69 73 20 68 6f 73 74 he dbs this host
1b40: 20 63 75 72 72 65 6e 74 6c 79 20 6f 77 6e 73 0a currently owns.
1b50: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 70 69 6e 67 ;;.(define (ping
1b60: 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 udata host-port
1b70: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 ). (let* ((star
1b80: 74 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c t (current-mill
1b90: 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 63 6f iseconds)).. (co
1ba0: 6f 6b 69 65 20 28 6d 61 6b 65 2d 63 6f 6f 6b 69 okie (make-cooki
1bb0: 65 20 75 64 61 74 61 29 29 0a 09 20 28 64 62 73 e udata)).. (dbs
1bc0: 20 20 20 20 28 75 64 61 74 2d 6d 79 2d 64 62 73 (udat-my-dbs
1bd0: 20 75 64 61 74 61 29 29 0a 09 20 28 6d 73 67 20 udata)).. (msg
1be0: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
1bf0: 73 70 65 72 73 65 20 64 62 73 20 22 20 22 29 29 sperse dbs " "))
1c00: 0a 09 20 28 72 65 73 20 28 73 65 6e 64 20 75 64 .. (res (send ud
1c10: 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 20 27 70 ata host-port 'p
1c20: 69 6e 67 20 63 6f 6f 6b 69 65 20 6d 73 67 20 72 ing cookie msg r
1c30: 65 74 76 61 6c 3a 20 23 74 29 29 0a 09 20 28 64 etval: #t)).. (d
1c40: 65 6c 74 61 20 28 2d 20 28 63 75 72 72 65 6e 74 elta (- (current
1c50: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 -milliseconds) s
1c60: 74 61 72 74 29 29 29 0a 20 20 20 20 28 76 61 6c tart))). (val
1c70: 75 65 73 20 28 65 71 75 61 6c 3f 20 72 65 73 20 ues (equal? res
1c80: 63 6f 6f 6b 69 65 29 20 64 65 6c 74 61 29 29 29 cookie) delta)))
1c90: 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 3a 20 73 75 ..;; returns: su
1ca0: 63 63 65 73 73 20 70 69 6e 67 74 69 6d 65 0a 3b ccess pingtime.;
1cb0: 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 63 61 75 73 65 ;.;; NOTE: cause
1cc0: 73 20 61 6c 6c 20 72 65 66 65 72 65 6e 63 65 73 s all references
1cd0: 20 74 6f 20 74 68 69 73 20 77 6f 72 6b 65 72 20 to this worker
1ce0: 74 6f 20 62 65 20 77 69 70 65 64 20 6f 75 74 20 to be wiped out
1cf0: 69 6e 20 74 68 65 0a 3b 3b 20 63 61 6c 6c 65 65 in the.;; callee
1d00: 20 28 75 73 75 73 61 6c 6c 79 20 74 68 65 20 63 (ususally the c
1d10: 61 70 74 61 69 6e 29 0a 3b 3b 0a 28 64 65 66 69 aptain).;;.(defi
1d20: 6e 65 20 28 67 6f 6f 64 62 79 65 2d 70 69 6e 67 ne (goodbye-ping
1d30: 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 udata host-port
1d40: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 ). (let* ((star
1d50: 74 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c t (current-mill
1d60: 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 63 6f iseconds)).. (co
1d70: 6f 6b 69 65 20 28 6d 61 6b 65 2d 63 6f 6f 6b 69 okie (make-cooki
1d80: 65 20 75 64 61 74 61 29 29 0a 09 20 28 64 62 73 e udata)).. (dbs
1d90: 20 20 20 20 28 75 64 61 74 2d 6d 79 2d 64 62 73 (udat-my-dbs
1da0: 20 75 64 61 74 61 29 29 0a 09 20 28 72 65 73 20 udata)).. (res
1db0: 28 73 65 6e 64 20 75 64 61 74 61 20 68 6f 73 74 (send udata host
1dc0: 2d 70 6f 72 74 20 27 67 6f 6f 64 62 79 65 20 63 -port 'goodbye c
1dd0: 6f 6f 6b 69 65 20 22 6e 6f 6d 73 67 22 20 72 65 ookie "nomsg" re
1de0: 74 76 61 6c 3a 20 23 74 29 29 0a 09 20 28 64 65 tval: #t)).. (de
1df0: 6c 74 61 20 28 2d 20 28 63 75 72 72 65 6e 74 2d lta (- (current-
1e00: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 milliseconds) st
1e10: 61 72 74 29 29 29 0a 20 20 20 20 28 76 61 6c 75 art))). (valu
1e20: 65 73 20 28 65 71 75 61 6c 3f 20 72 65 73 20 63 es (equal? res c
1e30: 6f 6f 6b 69 65 29 20 64 65 6c 74 61 29 29 29 0a ookie) delta))).
1e40: 0a 28 64 65 66 69 6e 65 20 28 67 6f 6f 64 62 79 .(define (goodby
1e50: 65 2d 63 61 70 74 61 69 6e 20 75 64 61 74 61 29 e-captain udata)
1e60: 0a 20 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 2d . (let* ((host-
1e70: 70 6f 72 74 20 28 75 64 61 74 2d 63 61 70 74 61 port (udat-capta
1e80: 69 6e 2d 68 6f 73 74 2d 70 6f 72 74 20 75 64 61 in-host-port uda
1e90: 74 61 29 29 29 0a 20 20 20 20 28 69 66 20 68 6f ta))). (if ho
1ea0: 73 74 2d 70 6f 72 74 0a 09 28 67 6f 6f 64 62 79 st-port..(goodby
1eb0: 65 2d 70 69 6e 67 20 75 64 61 74 61 20 68 6f 73 e-ping udata hos
1ec0: 74 2d 70 6f 72 74 29 0a 09 28 76 61 6c 75 65 73 t-port)..(values
1ed0: 20 23 66 20 2d 31 29 29 29 29 0a 0a 28 64 65 66 #f -1))))..(def
1ee0: 69 6e 65 20 28 67 65 74 2d 64 62 2d 6f 77 6e 65 ine (get-db-owne
1ef0: 72 20 75 64 61 74 61 20 64 62 6e 61 6d 65 20 64 r udata dbname d
1f00: 62 74 79 70 65 29 0a 20 20 28 6c 65 74 2a 20 28 btype). (let* (
1f10: 28 68 6f 73 74 2d 70 6f 72 74 20 28 75 64 61 74 (host-port (udat
1f20: 2d 63 61 70 74 61 69 6e 2d 68 6f 73 74 2d 70 6f -captain-host-po
1f30: 72 74 20 75 64 61 74 61 29 29 29 0a 20 20 20 20 rt udata))).
1f40: 28 69 66 20 68 6f 73 74 2d 70 6f 72 74 0a 09 28 (if host-port..(
1f50: 6c 65 74 2a 20 28 28 63 6f 6f 6b 69 65 20 28 6d let* ((cookie (m
1f60: 61 6b 65 2d 63 6f 6f 6b 69 65 20 75 64 61 74 61 ake-cookie udata
1f70: 29 29 0a 09 20 20 20 20 20 20 20 28 6d 73 67 20 )).. (msg
1f80: 20 20 20 23 66 29 20 3b 3b 20 28 63 6f 6e 63 20 #f) ;; (conc
1f90: 64 62 6e 61 6d 65 20 22 20 22 20 64 62 74 79 70 dbname " " dbtyp
1fa0: 65 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 72 e)).. (par
1fb0: 61 6d 73 20 60 28 2c 64 62 6e 61 6d 65 20 2c 64 ams `(,dbname ,d
1fc0: 62 74 79 70 65 29 29 0a 09 20 20 20 20 20 20 20 btype))..
1fd0: 28 72 65 73 20 20 20 20 28 73 65 6e 64 20 75 64 (res (send ud
1fe0: 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 20 27 64 ata host-port 'd
1ff0: 62 2d 6f 77 6e 65 72 20 63 6f 6f 6b 69 65 20 6d b-owner cookie m
2000: 73 67 0a 09 09 09 20 20 20 20 20 70 61 72 61 6d sg.... param
2010: 73 3a 20 70 61 72 61 6d 73 20 72 65 74 76 61 6c s: params retval
2020: 3a 20 23 74 29 29 29 0a 09 20 20 28 6d 61 74 63 : #t))).. (matc
2030: 68 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 h (string-split
2040: 72 65 73 29 0a 09 20 20 20 20 28 28 72 65 74 63 res).. ((retc
2050: 6f 6f 6b 69 65 20 6f 77 6e 65 72 2d 68 6f 73 74 ookie owner-host
2060: 2d 70 6f 72 74 29 0a 09 20 20 20 20 20 28 76 61 -port).. (va
2070: 6c 75 65 73 20 28 65 71 75 61 6c 3f 20 72 65 74 lues (equal? ret
2080: 63 6f 6f 6b 69 65 20 63 6f 6f 6b 69 65 29 20 6f cookie cookie) o
2090: 77 6e 65 72 2d 68 6f 73 74 2d 70 6f 72 74 29 29 wner-host-port))
20a0: 29 29 0a 09 28 76 61 6c 75 65 73 20 23 66 20 2d ))..(values #f -
20b0: 31 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 65 64 1))))..;; called
20c0: 20 69 6e 20 75 6c 65 78 2d 68 61 6e 64 6c 65 72 in ulex-handler
20d0: 20 74 6f 20 64 69 73 70 61 74 63 68 20 77 6f 72 to dispatch wor
20e0: 6b 2c 20 63 61 6c 6c 65 64 20 6f 6e 20 74 68 65 k, called on the
20f0: 20 77 6f 72 6b 65 72 73 20 73 69 64 65 0a 3b 3b workers side.;;
2100: 20 20 20 20 20 63 61 6c 6c 73 20 28 70 72 6f 63 calls (proc
2110: 20 70 61 72 61 6d 73 20 64 61 74 61 29 0a 3b 3b params data).;;
2120: 20 20 20 20 20 72 65 74 75 72 6e 73 20 72 65 73 returns res
2130: 75 6c 74 20 77 69 74 68 20 63 6f 6f 6b 69 65 0a ult with cookie.
2140: 3b 3b 0a 3b 3b 20 70 64 61 74 20 69 73 20 74 68 ;;.;; pdat is th
2150: 65 20 69 6e 66 6f 20 6f 66 20 74 68 65 20 63 61 e info of the ca
2160: 6c 6c 65 72 2c 20 75 73 65 64 20 74 6f 20 73 65 ller, used to se
2170: 6e 64 20 74 68 65 20 72 65 73 75 6c 74 20 64 61 nd the result da
2180: 74 61 0a 3b 3b 20 70 72 6f 63 6b 65 79 20 69 73 ta.;; prockey is
2190: 20 6b 65 79 20 69 6e 74 6f 20 75 64 61 74 2d 68 key into udat-h
21a0: 61 6e 64 6c 65 72 73 20 68 61 73 68 20 64 65 72 andlers hash der
21b0: 65 66 65 72 65 6e 63 69 6e 67 20 61 20 70 72 6f eferencing a pro
21c0: 63 0a 3b 3b 20 70 72 6f 63 70 61 72 61 6d 20 69 c.;; procparam i
21d0: 73 20 61 20 66 69 72 73 74 20 70 61 72 61 6d 20 s a first param
21e0: 68 61 6e 64 65 64 20 74 6f 20 70 72 6f 63 20 2d handed to proc -
21f0: 20 6f 66 74 65 6e 20 74 6f 20 64 6f 20 66 75 72 often to do fur
2200: 74 68 65 72 20 64 65 72 65 66 72 65 6e 63 69 6e ther derefrencin
2210: 67 0a 3b 3b 20 4e 4f 54 45 3a 20 70 61 72 61 6d g.;; NOTE: param
2220: 73 20 69 73 20 69 6e 74 65 6e 64 65 64 20 74 6f s is intended to
2230: 20 62 65 20 61 20 6c 69 73 74 20 6f 66 20 73 74 be a list of st
2240: 72 69 6e 67 73 2c 20 65 6e 63 6f 64 69 6e 67 20 rings, encoding
2250: 6f 6e 20 64 61 74 61 0a 3b 3b 20 20 20 20 20 20 on data.;;
2260: 20 69 73 20 75 70 20 74 6f 20 74 68 65 20 75 73 is up to the us
2270: 65 72 20 62 75 74 20 64 61 74 61 20 6d 75 73 74 er but data must
2280: 20 62 65 20 61 20 73 69 6e 67 6c 65 20 6c 69 6e be a single lin
2290: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 70 72 e.;;.(define (pr
22a0: 6f 63 65 73 73 2d 72 65 71 75 65 73 74 20 75 64 ocess-request ud
22b0: 61 74 61 20 70 64 61 74 20 64 62 6e 61 6d 65 20 ata pdat dbname
22c0: 63 6f 6f 6b 69 65 20 70 72 6f 63 6b 65 79 20 70 cookie prockey p
22d0: 72 6f 63 70 61 72 61 6d 20 64 61 74 61 29 0a 20 rocparam data).
22e0: 20 28 6c 65 74 2a 20 28 28 64 62 72 65 63 20 28 (let* ((dbrec (
22f0: 75 6c 65 78 2d 6f 70 65 6e 2d 64 62 20 75 64 61 ulex-open-db uda
2300: 74 61 20 64 62 6e 61 6d 65 29 29 20 20 20 20 20 ta dbname))
2310: 3b 3b 20 74 68 69 73 20 77 69 6c 6c 20 62 65 20 ;; this will be
2320: 61 20 64 62 63 6f 6e 6e 20 72 65 63 6f 72 64 2c a dbconn record,
2330: 20 6c 6f 6f 6b 73 20 66 6f 72 20 69 6e 20 75 64 looks for in ud
2340: 61 74 61 20 66 69 72 73 74 0a 09 20 28 70 72 6f ata first.. (pro
2350: 63 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 c (hash-table-r
2360: 65 66 20 75 64 61 74 61 20 70 72 6f 63 6b 65 79 ef udata prockey
2370: 29 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 ))). (let* ((
2380: 72 65 73 75 6c 74 20 28 70 72 6f 63 20 64 62 72 result (proc dbr
2390: 65 63 20 70 72 6f 63 70 61 72 61 6d 20 64 61 74 ec procparam dat
23a0: 61 29 29 29 0a 20 20 20 20 20 20 72 65 73 75 6c a))). resul
23b0: 74 29 29 29 0a 0a 3b 3b 20 72 65 6d 6f 74 65 2d t)))..;; remote-
23c0: 72 65 71 75 65 73 74 20 2d 20 73 65 6e 64 20 74 request - send t
23d0: 6f 20 72 65 6d 6f 74 65 20 74 6f 20 70 72 6f 63 o remote to proc
23e0: 65 73 73 20 69 6e 20 70 72 6f 63 65 73 73 2d 72 ess in process-r
23f0: 65 71 75 65 73 74 0a 3b 3b 20 75 63 6f 6e 6e 20 equest.;; uconn
2400: 63 6f 6d 65 73 20 66 72 6f 6d 20 61 20 63 61 6c comes from a cal
2410: 6c 20 74 6f 20 63 6f 6e 6e 65 63 74 20 61 6e 64 l to connect and
2420: 20 63 61 6e 20 62 65 20 75 73 65 64 20 69 6e 73 can be used ins
2430: 74 65 61 64 20 6f 66 20 63 61 6c 6c 69 6e 67 20 tead of calling
2440: 63 6f 6e 6e 65 63 74 20 61 67 61 69 6e 0a 3b 3b connect again.;;
2450: 20 75 63 6f 6e 6e 20 69 73 20 74 68 65 20 68 6f uconn is the ho
2460: 73 74 2d 70 6f 72 74 20 74 6f 20 63 61 6c 6c 0a st-port to call.
2470: 3b 3b 20 77 65 20 73 65 6e 64 20 64 62 6e 61 6d ;; we send dbnam
2480: 65 20 74 6f 20 74 68 65 20 77 6f 72 6b 65 72 20 e to the worker
2490: 73 6f 20 74 68 65 79 20 6b 6e 6f 77 20 77 68 69 so they know whi
24a0: 63 68 20 66 69 6c 65 20 74 6f 20 6f 70 65 6e 0a ch file to open.
24b0: 3b 3b 20 64 61 74 61 20 6d 75 73 74 20 62 65 20 ;; data must be
24c0: 61 20 73 74 72 69 6e 67 20 77 69 74 68 20 6e 6f a string with no
24d0: 20 6e 65 77 6c 69 6e 65 73 2c 20 69 74 20 77 69 newlines, it wi
24e0: 6c 6c 20 62 65 20 68 61 6e 64 65 64 20 74 6f 20 ll be handed to
24f0: 74 68 65 20 70 72 6f 63 0a 3b 3b 20 61 74 20 74 the proc.;; at t
2500: 68 65 20 72 65 6d 6f 74 65 20 73 69 74 65 20 75 he remote site u
2510: 6e 63 68 61 6e 67 65 64 2e 20 49 74 20 69 73 20 nchanged. It is
2520: 75 70 20 74 6f 20 74 68 65 20 75 73 65 72 20 74 up to the user t
2530: 6f 20 65 6e 63 6f 64 65 2f 64 65 63 6f 64 65 20 o encode/decode
2540: 69 74 27 73 20 63 6f 6e 74 65 6e 74 73 0a 3b 3b it's contents.;;
2550: 0a 3b 3b 20 20 20 72 74 79 70 65 3a 20 69 6d 6d .;; rtype: imm
2560: 65 64 69 61 74 65 2c 20 72 65 61 64 2d 6f 6e 6c ediate, read-onl
2570: 79 2c 20 6e 6f 72 6d 61 6c 2c 20 6c 6f 77 2d 70 y, normal, low-p
2580: 72 69 6f 72 69 74 79 0a 3b 3b 20 0a 28 64 65 66 riority.;; .(def
2590: 69 6e 65 20 28 72 65 6d 6f 74 65 2d 72 65 71 75 ine (remote-requ
25a0: 65 73 74 20 75 64 61 74 61 20 75 63 6f 6e 6e 20 est udata uconn
25b0: 72 74 79 70 65 20 64 62 6e 61 6d 65 20 70 72 6f rtype dbname pro
25c0: 63 6b 65 79 20 70 72 6f 63 70 61 72 61 6d 20 64 ckey procparam d
25d0: 61 74 61 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 ata). (let* ((c
25e0: 6f 6f 6b 69 65 20 20 20 20 28 6d 61 6b 65 2d 63 ookie (make-c
25f0: 6f 6f 6b 69 65 20 75 64 61 74 61 29 29 29 0a 20 ookie udata))).
2600: 20 20 20 28 73 65 6e 64 2d 72 65 63 65 69 76 65 (send-receive
2610: 20 75 64 61 74 61 20 75 63 6f 6e 6e 20 72 74 79 udata uconn rty
2620: 70 65 20 63 6f 6f 6b 69 65 20 64 61 74 61 20 60 pe cookie data `
2630: 28 2c 70 72 6f 63 6b 65 79 20 70 72 6f 63 70 61 (,prockey procpa
2640: 72 61 6d 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ram))))..(define
2650: 20 28 75 6c 65 78 2d 6f 70 65 6e 2d 64 62 20 75 (ulex-open-db u
2660: 64 61 74 61 20 64 62 6e 61 6d 65 29 0a 20 20 23 data dbname). #
2670: 66 29 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d f)...;;=========
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
26c0: 20 55 6c 65 78 20 64 62 0a 3b 3b 0a 3b 3b 20 20 Ulex db.;;.;;
26d0: 20 2d 20 74 72 61 63 6b 20 77 68 6f 20 69 73 20 - track who is
26e0: 63 61 70 74 61 69 6e 2c 20 6c 65 61 73 65 20 65 captain, lease e
26f0: 78 70 69 72 65 20 74 69 6d 65 0a 3b 3b 20 20 20 xpire time.;;
2700: 2d 20 74 72 61 63 6b 20 77 68 6f 20 6f 77 6e 73 - track who owns
2710: 20 77 68 61 74 20 64 62 2c 20 6c 65 61 73 65 0a what db, lease.
2720: 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;.;;===========
2730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 0a ===========..;;.
2770: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 75 6c 65 78 ;;.(define (ulex
2780: 2d 64 62 66 6e 61 6d 65 29 0a 20 20 28 6c 65 74 -dbfname). (let
2790: 20 28 28 64 62 64 69 72 20 28 63 6f 6e 63 20 28 ((dbdir (conc (
27a0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
27b0: 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 variable "HOME")
27c0: 20 22 2f 2e 75 6c 65 78 22 29 29 29 0a 20 20 20 "/.ulex"))).
27d0: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
27e0: 65 78 69 73 74 73 3f 20 64 62 64 69 72 29 29 0a exists? dbdir)).
27f0: 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f .(create-directo
2800: 72 79 20 64 62 64 69 72 20 23 74 29 29 0a 20 20 ry dbdir #t)).
2810: 20 20 28 63 6f 6e 63 20 64 62 64 69 72 20 22 2f (conc dbdir "/
2820: 6e 65 74 77 6f 72 6b 2e 64 62 22 29 29 29 0a 09 network.db")))..
2830: 20 0a 3b 3b 20 61 6c 77 61 79 73 20 67 6f 65 73 .;; always goes
2840: 20 69 6e 20 7e 2f 2e 75 6c 65 78 2f 6e 65 74 77 in ~/.ulex/netw
2850: 6f 72 6b 2e 64 62 0a 3b 3b 20 72 6f 6c 65 20 69 ork.db.;; role i
2860: 73 20 63 61 70 74 61 69 6e 2c 20 61 64 6a 75 74 s captain, adjut
2870: 61 6e 74 2c 20 6e 6f 64 65 0a 3b 3b 0a 28 64 65 ant, node.;;.(de
2880: 66 69 6e 65 20 28 75 6c 65 78 64 62 2d 73 65 74 fine (ulexdb-set
2890: 75 70 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 up). (let* ((db
28a0: 66 6e 61 6d 65 20 28 75 6c 65 78 2d 64 62 66 6e fname (ulex-dbfn
28b0: 61 6d 65 29 29 0a 09 20 28 68 61 76 65 2d 64 62 ame)).. (have-db
28c0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 (file-exists? d
28d0: 62 66 6e 61 6d 65 29 29 0a 09 20 28 64 62 20 20 bfname)).. (db
28e0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 (sqlite3:ope
28f0: 6e 2d 64 61 74 61 62 61 73 65 20 64 62 66 6e 61 n-database dbfna
2900: 6d 65 29 29 29 0a 20 20 20 20 28 73 71 6c 69 74 me))). (sqlit
2910: 65 33 3a 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 e3:set-busy-hand
2920: 6c 65 72 21 20 64 62 20 28 73 71 6c 69 74 65 33 ler! db (sqlite3
2930: 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 69 6d 65 6f :make-busy-timeo
2940: 75 74 20 31 33 36 30 30 30 29 29 0a 20 20 20 20 ut 136000)).
2950: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
2960: 20 64 62 20 22 50 52 41 47 4d 41 20 73 79 6e 63 db "PRAGMA sync
2970: 68 72 6f 6e 6f 75 73 20 3d 20 30 3b 22 29 0a 20 hronous = 0;").
2980: 20 20 20 28 69 66 20 28 6e 6f 74 20 68 61 76 65 (if (not have
2990: 2d 64 62 29 0a 09 28 73 71 6c 69 74 65 33 3a 77 -db)..(sqlite3:w
29a0: 69 74 68 2d 74 72 61 6e 73 61 63 74 69 6f 6e 0a ith-transaction.
29b0: 09 20 64 62 0a 09 20 28 6c 61 6d 62 64 61 20 28 . db.. (lambda (
29c0: 29 0a 09 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ).. (for-each.
29d0: 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 . (lambda (st
29e0: 6d 74 29 0a 09 20 20 20 20 20 20 28 69 66 20 73 mt).. (if s
29f0: 74 6d 74 20 28 73 71 6c 69 74 65 33 3a 65 78 65 tmt (sqlite3:exe
2a00: 63 75 74 65 20 64 62 20 73 74 6d 74 29 29 29 0a cute db stmt))).
2a10: 09 20 20 20 20 60 28 22 43 52 45 41 54 45 20 54 . `("CREATE T
2a20: 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 ABLE IF NOT EXIS
2a30: 54 53 20 6e 6f 64 65 73 0a 20 20 20 20 20 20 20 TS nodes.
2a40: 20 20 20 20 20 20 20 20 20 20 28 69 64 20 49 4e (id IN
2a50: 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 TEGER PRIMARY KE
2a60: 59 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 Y,.
2a70: 20 20 20 20 20 72 6f 6c 65 20 20 54 45 58 54 20 role TEXT
2a80: 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 NOT NULL,.
2a90: 20 20 20 20 20 20 20 20 20 20 20 20 68 6f 73 74 host
2aa0: 20 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c TEXT NOT NULL,
2ab0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2ac0: 20 20 20 70 6f 72 74 20 54 45 58 54 20 4e 4f 54 port TEXT NOT
2ad0: 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 NULL,.
2ae0: 20 20 20 20 20 20 20 20 20 69 70 61 64 72 20 54 ipadr T
2af0: 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 EXT NOT NULL,.
2b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b10: 70 69 64 20 20 20 49 4e 54 45 47 45 52 20 4e 4f pid INTEGER NO
2b20: 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 T NULL,.
2b30: 20 20 20 20 20 20 20 20 20 20 7a 63 61 72 64 20 zcard
2b40: 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 TEXT NOT NULL,.
2b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b60: 20 72 65 67 74 69 6d 65 20 49 4e 54 45 47 45 52 regtime INTEGER
2b70: 20 44 45 46 41 55 4c 54 20 28 73 74 72 66 74 69 DEFAULT (strfti
2b80: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c me('%s','now')),
2b90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2ba0: 20 20 20 6c 65 61 73 65 5f 74 68 72 75 20 49 4e lease_thru IN
2bb0: 54 45 47 45 52 20 44 45 46 41 55 4c 54 20 28 73 TEGER DEFAULT (s
2bc0: 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f trftime('%s','no
2bd0: 77 27 29 29 2c 0a 20 20 20 20 20 20 20 20 20 20 w')),.
2be0: 20 20 20 20 20 20 20 20 6c 61 73 74 5f 75 70 64 last_upd
2bf0: 61 74 65 20 49 4e 54 45 47 45 52 20 44 45 46 41 ate INTEGER DEFA
2c00: 55 4c 54 20 28 73 74 72 66 74 69 6d 65 28 27 25 ULT (strftime('%
2c10: 73 27 2c 27 6e 6f 77 27 29 29 29 3b 22 0a 09 20 s','now')));"..
2c20: 20 20 20 20 20 22 43 52 45 41 54 45 20 54 52 49 "CREATE TRI
2c30: 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 58 49 GGER IF NOT EXI
2c40: 53 54 53 20 75 70 64 61 74 65 5f 6e 6f 64 65 73 STS update_nodes
2c50: 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 20 55 _trigger AFTER U
2c60: 50 44 41 54 45 20 4f 4e 20 6e 6f 64 65 73 0a 20 PDATE ON nodes.
2c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c80: 20 20 20 20 20 20 20 20 20 20 20 20 46 4f 52 20 FOR
2c90: 45 41 43 48 20 52 4f 57 0a 20 20 20 20 20 20 20 EACH ROW.
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 42 45 47 49 4e 20 0a 20 BEGIN .
2cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ce0: 55 50 44 41 54 45 20 6e 6f 64 65 73 20 53 45 54 UPDATE nodes SET
2cf0: 20 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 73 74 last_update=(st
2d00: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
2d10: 27 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ')).
2d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d30: 20 20 20 20 20 20 20 57 48 45 52 45 20 69 64 3d WHERE id=
2d40: 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 old.id;.
2d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d60: 20 20 20 20 20 20 20 45 4e 44 3b 22 0a 09 20 20 END;"..
2d70: 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 4c "CREATE TABL
2d80: 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 E IF NOT EXISTS
2d90: 64 62 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 dbs.
2da0: 20 20 20 20 20 28 69 64 20 49 4e 54 45 47 45 52 (id INTEGER
2db0: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 PRIMARY KEY,.
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2dd0: 64 62 6e 61 6d 65 20 54 45 58 54 20 4e 4f 54 20 dbname TEXT NOT
2de0: 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 NULL,.
2df0: 20 20 20 20 20 20 20 20 64 62 66 69 6c 65 20 54 dbfile T
2e00: 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 EXT NOT NULL,.
2e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e20: 64 62 74 79 70 65 20 54 45 58 54 20 4e 4f 54 20 dbtype TEXT NOT
2e30: 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 NULL,.
2e40: 20 20 20 20 20 20 20 20 68 6f 73 74 5f 70 6f 72 host_por
2e50: 74 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c t TEXT NOT NULL,
2e60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2e70: 20 20 20 72 65 67 74 69 6d 65 20 49 4e 54 45 47 regtime INTEG
2e80: 45 52 20 44 45 46 41 55 4c 54 20 28 73 74 72 66 ER DEFAULT (strf
2e90: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
2ea0: 29 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ),.
2eb0: 20 20 20 20 20 6c 65 61 73 65 5f 74 68 72 75 20 lease_thru
2ec0: 49 4e 54 45 47 45 52 20 44 45 46 41 55 4c 54 20 INTEGER DEFAULT
2ed0: 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 (strftime('%s','
2ee0: 6e 6f 77 27 29 29 2c 0a 20 20 20 20 20 20 20 20 now')),.
2ef0: 20 20 20 20 20 20 20 20 20 20 6c 61 73 74 5f 75 last_u
2f00: 70 64 61 74 65 20 49 4e 54 45 47 45 52 20 44 45 pdate INTEGER DE
2f10: 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d 65 28 FAULT (strftime(
2f20: 27 25 73 27 2c 27 6e 6f 77 27 29 29 29 3b 22 0a '%s','now')));".
2f30: 09 20 20 20 20 20 20 22 43 52 45 41 54 45 20 54 . "CREATE T
2f40: 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 RIGGER IF NOT E
2f50: 58 49 53 54 53 20 75 70 64 61 74 65 5f 64 62 73 XISTS update_dbs
2f60: 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 20 55 _trigger AFTER U
2f70: 50 44 41 54 45 20 4f 4e 20 64 62 73 0a 20 20 20 PDATE ON dbs.
2f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f90: 20 20 20 20 20 20 20 20 20 20 46 4f 52 20 45 41 FOR EA
2fa0: 43 48 20 52 4f 57 0a 20 20 20 20 20 20 20 20 20 CH ROW.
2fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fc0: 20 20 20 20 20 20 42 45 47 49 4e 20 0a 20 20 20 BEGIN .
2fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 55 50 UP
2ff0: 44 41 54 45 20 64 62 73 20 53 45 54 20 6c 61 73 DATE dbs SET las
3000: 74 5f 75 70 64 61 74 65 3d 28 73 74 72 66 74 69 t_update=(strfti
3010: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a me('%s','now')).
3020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3040: 20 20 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e WHERE id=old.
3050: 69 64 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 id;.
3060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3070: 20 20 20 45 4e 44 3b 22 29 29 29 29 29 0a 20 20 END;"))))).
3080: 20 20 64 62 29 29 0a 0a 28 64 65 66 69 6e 65 20 db))..(define
3090: 28 67 65 74 2d 68 6f 73 74 2d 70 6f 72 74 2d 6c (get-host-port-l
30a0: 65 61 73 65 20 64 62 20 64 62 66 6e 61 6d 65 29 ease db dbfname)
30b0: 0a 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 6c 64 . (sqlite3:fold
30c0: 2d 72 6f 77 0a 20 20 20 28 6c 61 6d 62 64 61 20 -row. (lambda
30d0: 28 72 65 6d 20 68 6f 73 74 2d 70 6f 72 74 20 6c (rem host-port l
30e0: 65 61 73 65 2d 74 68 72 75 29 0a 20 20 20 20 20 ease-thru).
30f0: 28 6c 69 73 74 20 68 6f 73 74 2d 70 6f 72 74 20 (list host-port
3100: 6c 65 61 73 65 2d 74 68 72 75 29 29 0a 20 20 20 lease-thru)).
3110: 23 66 20 64 62 20 22 53 45 4c 45 43 54 20 68 6f #f db "SELECT ho
3120: 73 74 5f 70 6f 72 74 2c 6c 65 61 73 65 5f 74 68 st_port,lease_th
3130: 72 75 20 46 52 4f 4d 20 64 62 73 20 57 48 45 52 ru FROM dbs WHER
3140: 45 20 64 62 66 69 6c 65 20 3d 20 3f 22 20 64 62 E dbfile = ?" db
3150: 66 6e 61 6d 65 29 29 0a 20 20 0a 28 64 65 66 69 fname)). .(defi
3160: 6e 65 20 28 72 65 67 69 73 74 65 72 2d 63 61 70 ne (register-cap
3170: 74 61 69 6e 20 64 62 20 68 6f 73 74 20 69 70 61 tain db host ipa
3180: 64 72 20 70 6f 72 74 20 70 69 64 20 7a 63 61 72 dr port pid zcar
3190: 64 20 23 21 6b 65 79 20 28 6c 65 61 73 65 20 32 d #!key (lease 2
31a0: 30 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 0)). (let* ((db
31b0: 66 6e 61 6d 65 20 28 75 6c 65 78 2d 64 62 66 6e fname (ulex-dbfn
31c0: 61 6d 65 29 29 0a 09 20 28 68 6f 73 74 2d 70 6f ame)).. (host-po
31d0: 72 74 20 20 28 63 6f 6e 63 20 68 6f 73 74 20 22 rt (conc host "
31e0: 3a 22 20 70 6f 72 74 29 29 29 0a 20 20 20 20 28 :" port))). (
31f0: 73 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 61 sqlite3:with-tra
3200: 6e 73 61 63 74 69 6f 6e 0a 20 20 20 20 20 64 62 nsaction. db
3210: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 . (lambda ()
3220: 0a 20 20 20 20 20 20 20 28 6d 61 74 63 68 20 28 . (match (
3230: 67 65 74 2d 68 6f 73 74 2d 70 6f 72 74 2d 6c 65 get-host-port-le
3240: 61 73 65 20 64 62 20 64 62 66 6e 61 6d 65 29 0a ase db dbfname).
3250: 09 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 6c 65 . ((host-port le
3260: 61 73 65 2d 74 68 72 75 29 0a 09 20 20 28 69 66 ase-thru).. (if
3270: 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (> (current-sec
3280: 6f 6e 64 73 29 20 6c 65 61 73 65 2d 74 68 72 75 onds) lease-thru
3290: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
32a0: 09 09 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 ..(sqlite3:execu
32b0: 74 65 20 64 62 20 22 55 50 44 41 54 45 20 64 62 te db "UPDATE db
32c0: 73 20 53 45 54 20 68 6f 73 74 5f 70 6f 72 74 3d s SET host_port=
32d0: 3f 2c 6c 65 61 73 65 5f 74 68 72 75 3d 3f 20 57 ?,lease_thru=? W
32e0: 48 45 52 45 20 64 62 6e 61 6d 65 3d 3f 22 0a 09 HERE dbname=?"..
32f0: 09 09 09 20 28 63 6f 6e 63 20 68 6f 73 74 20 22 ... (conc host "
3300: 3a 22 20 70 6f 72 74 29 0a 09 09 09 09 20 28 2b :" port)..... (+
3310: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
3320: 73 29 20 6c 65 61 73 65 29 0a 09 09 09 09 20 64 s) lease)..... d
3330: 62 66 6e 61 6d 65 29 0a 09 09 23 74 29 0a 09 20 bfname)...#t)..
3340: 20 20 20 20 20 23 66 29 29 0a 09 20 28 23 66 20 #f)).. (#f
3350: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
3360: 65 20 64 62 20 22 49 4e 53 45 52 54 20 49 4e 54 e db "INSERT INT
3370: 4f 20 64 62 73 20 28 64 62 6e 61 6d 65 2c 64 62 O dbs (dbname,db
3380: 66 69 6c 65 2c 64 62 74 79 70 65 2c 68 6f 73 74 file,dbtype,host
3390: 5f 70 6f 72 74 2c 6c 65 61 73 65 5f 74 68 72 75 _port,lease_thru
33a0: 29 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c ) VALUES (?,?,?,
33b0: 3f 2c 3f 29 22 0a 09 09 09 20 20 20 20 20 20 20 ?,?)"....
33c0: 22 63 61 70 74 61 69 6e 22 20 64 62 66 6e 61 6d "captain" dbfnam
33d0: 65 20 22 63 61 70 74 61 69 6e 22 20 68 6f 73 74 e "captain" host
33e0: 2d 70 6f 72 74 20 28 2b 20 28 63 75 72 72 65 6e -port (+ (curren
33f0: 74 2d 73 65 63 6f 6e 64 73 29 20 6c 65 61 73 65 t-seconds) lease
3400: 29 29 29 0a 09 20 28 65 6c 73 65 20 28 70 72 69 ))).. (else (pri
3410: 6e 74 20 22 45 52 52 4f 52 3a 20 55 6e 72 65 63 nt "ERROR: Unrec
3420: 6f 67 6e 69 73 65 64 20 72 65 73 75 6c 74 20 66 ognised result f
3430: 72 6f 6d 20 66 6f 6c 64 2d 72 6f 77 22 29 0a 09 rom fold-row")..
3440: 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
3450: 29 29 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 )))))........
3460: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
3470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 6e 65 ==========.;; ne
34b0: 74 77 6f 72 6b 20 75 74 69 6c 69 74 69 65 73 0a twork utilities.
34c0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
34d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 28 64 65 66 69 6e ========..(defin
3510: 65 20 28 72 61 74 65 2d 69 70 20 69 70 61 64 64 e (rate-ip ipadd
3520: 72 29 0a 20 20 28 72 65 67 65 78 2d 63 61 73 65 r). (regex-case
3530: 20 69 70 61 64 64 72 0a 20 20 20 20 28 20 22 5e ipaddr. ( "^
3540: 31 32 37 5c 5c 2e 2e 2a 22 20 5f 20 30 20 29 0a 127\\..*" _ 0 ).
3550: 20 20 20 20 28 20 22 5e 28 31 30 5c 5c 2e 30 7c ( "^(10\\.0|
3560: 31 39 32 5c 5c 2e 31 36 38 29 5c 5c 2e 2e 2a 22 192\\.168)\\..*"
3570: 20 5f 20 31 20 29 0a 20 20 20 20 28 20 65 6c 73 _ 1 ). ( els
3580: 65 20 32 20 29 20 29 29 0a 0a 3b 3b 20 43 68 61 e 2 ) ))..;; Cha
3590: 6e 67 65 20 74 68 69 73 20 74 6f 20 62 69 61 73 nge this to bias
35a0: 20 66 6f 72 20 61 64 64 72 65 73 73 65 73 20 77 for addresses w
35b0: 69 74 68 20 61 20 72 65 61 73 6f 6e 61 62 6c 65 ith a reasonable
35c0: 20 62 72 6f 61 64 63 61 73 74 20 76 61 6c 75 65 broadcast value
35d0: 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 69 70 ?.;;.(define (ip
35e0: 2d 70 72 65 66 2d 6c 65 73 73 3f 20 61 20 62 29 -pref-less? a b)
35f0: 0a 20 20 28 3e 20 28 72 61 74 65 2d 69 70 20 61 . (> (rate-ip a
3600: 29 20 28 72 61 74 65 2d 69 70 20 62 29 29 29 0a ) (rate-ip b))).
3610: 20 20 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 ..(define (get
3620: 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 73 73 -my-best-address
3630: 29 0a 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d 6d ). (let ((all-m
3640: 79 2d 61 64 64 72 65 73 73 65 73 20 28 67 65 74 y-addresses (get
3650: 2d 61 6c 6c 2d 69 70 73 29 29 0a 20 20 20 20 20 -all-ips)).
3660: 20 20 20 3b 3b 28 61 6c 6c 2d 6d 79 2d 61 64 64 ;;(all-my-add
3670: 72 65 73 73 65 73 2d 6f 6c 64 20 28 76 65 63 74 resses-old (vect
3680: 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 69 6e or->list (hostin
3690: 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f fo-addresses (ho
36a0: 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f stname->hostinfo
36b0: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
36c0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 29 0a 20 )))). ).
36d0: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
36e0: 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 64 64 null? all-my-add
36f0: 72 65 73 73 65 73 29 0a 20 20 20 20 20 20 28 67 resses). (g
3700: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 20 20 et-host-name))
3710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3730: 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 69 6e ;; no in
3740: 74 65 72 66 61 63 65 73 3f 0a 20 20 20 20 20 28 terfaces?. (
3750: 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 61 6c 6c (eq? (length all
3760: 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 20 31 -my-addresses) 1
3770: 29 0a 20 20 20 20 20 20 28 63 61 72 20 61 6c 6c ). (car all
3780: 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 29 20 -my-addresses))
3790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37a0: 20 20 20 20 20 3b 3b 20 6f 6e 6c 79 20 6f 6e 65 ;; only one
37b0: 20 74 6f 20 63 68 6f 6f 73 65 20 66 72 6f 6d 2c to choose from,
37c0: 20 6a 75 73 74 20 67 6f 20 77 69 74 68 20 69 74 just go with it
37d0: 0a 20 20 20 20 20 0a 20 20 20 20 20 28 65 6c 73 . . (els
37e0: 65 0a 20 20 20 20 20 20 28 63 61 72 20 28 73 6f e. (car (so
37f0: 72 74 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 rt all-my-addres
3800: 73 65 73 20 69 70 2d 70 72 65 66 2d 6c 65 73 73 ses ip-pref-less
3810: 3f 29 29 29 0a 20 20 20 20 20 3b 3b 20 28 65 6c ?))). ;; (el
3820: 73 65 20 0a 20 20 20 20 20 3b 3b 20 20 28 69 70 se . ;; (ip
3830: 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 20 28 66 ->string (car (f
3840: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
3850: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
3860: 20 20 20 20 20 20 20 3b 3b 20 74 61 6b 65 20 61 ;; take a
3870: 6e 79 20 62 75 74 20 31 32 37 2e 0a 20 20 20 20 ny but 127..
3880: 20 3b 3b 20 20 20 20 09 09 09 20 28 6e 6f 74 20 ;; ... (not
3890: 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 (eq? (u8vector-r
38a0: 65 66 20 78 20 30 29 20 31 32 37 29 29 29 0a 20 ef x 0) 127))).
38b0: 20 20 20 20 3b 3b 20 20 20 20 09 09 20 20 20 20 ;; ..
38c0: 20 20 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 all-my-addres
38d0: 73 65 73 29 29 29 29 0a 0a 20 20 20 20 20 29 29 ses)))).. ))
38e0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d )..(define (get-
38f0: 61 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 29 0a all-ips-sorted).
3900: 20 20 28 73 6f 72 74 20 28 67 65 74 2d 61 6c 6c (sort (get-all
3910: 2d 69 70 73 29 20 69 70 2d 70 72 65 66 2d 6c 65 -ips) ip-pref-le
3920: 73 73 3f 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ss?))..(define (
3930: 67 65 74 2d 61 6c 6c 2d 69 70 73 29 0a 20 20 28 get-all-ips). (
3940: 6d 61 70 20 69 70 2d 3e 73 74 72 69 6e 67 20 28 map ip->string (
3950: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 0a 09 09 vector->list ...
3960: 20 20 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 (hostinfo-add
3970: 72 65 73 73 65 73 0a 09 09 20 20 20 20 28 68 6f resses... (ho
3980: 73 74 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 st-information (
3990: 63 75 72 72 65 6e 74 2d 68 6f 73 74 6e 61 6d 65 current-hostname
39a0: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
39b0: 28 75 64 61 74 2d 6d 79 2d 68 6f 73 74 2d 70 6f (udat-my-host-po
39c0: 72 74 20 75 64 61 74 61 29 0a 20 20 28 69 66 20 rt udata). (if
39d0: 28 61 6e 64 20 28 75 64 61 74 2d 6d 79 2d 61 64 (and (udat-my-ad
39e0: 64 72 65 73 73 20 75 64 61 74 61 29 28 75 64 61 dress udata)(uda
39f0: 74 2d 6d 79 2d 70 6f 72 74 20 75 64 61 74 61 29 t-my-port udata)
3a00: 29 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 28 75 ). (conc (u
3a10: 64 61 74 2d 6d 79 2d 61 64 64 72 65 73 73 20 75 dat-my-address u
3a20: 64 61 74 61 29 20 22 3a 22 20 28 75 64 61 74 2d data) ":" (udat-
3a30: 6d 79 2d 70 6f 72 74 20 75 64 61 74 61 29 29 0a my-port udata)).
3a40: 20 20 20 20 20 20 23 66 29 29 0a 0a 28 64 65 66 #f))..(def
3a50: 69 6e 65 20 28 75 64 61 74 2d 63 61 70 74 61 69 ine (udat-captai
3a60: 6e 2d 68 6f 73 74 2d 70 6f 72 74 20 75 64 61 74 n-host-port udat
3a70: 61 29 0a 20 20 28 69 66 20 28 61 6e 64 20 28 75 a). (if (and (u
3a80: 64 61 74 2d 63 61 70 74 61 69 6e 2d 61 64 64 72 dat-captain-addr
3a90: 65 73 73 20 75 64 61 74 61 29 28 75 64 61 74 2d ess udata)(udat-
3aa0: 63 61 70 74 61 69 6e 2d 70 6f 72 74 20 75 64 61 captain-port uda
3ab0: 74 61 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 63 ta)). (conc
3ac0: 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 61 (udat-captain-a
3ad0: 64 64 72 65 73 73 20 75 64 61 74 61 29 20 22 3a ddress udata) ":
3ae0: 22 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d " (udat-captain-
3af0: 70 6f 72 74 20 75 64 61 74 61 29 29 0a 20 20 20 port udata)).
3b00: 20 20 20 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 #f))..(define
3b10: 20 28 75 64 61 74 2d 67 65 74 2d 70 65 65 72 20 (udat-get-peer
3b20: 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 29 udata host-port)
3b30: 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 . (hash-table-r
3b40: 65 66 2f 64 65 66 61 75 6c 74 20 28 75 64 61 74 ef/default (udat
3b50: 2d 70 65 65 72 73 20 75 64 61 74 61 29 20 68 6f -peers udata) ho
3b60: 73 74 2d 70 6f 72 74 20 23 66 29 29 0a 0a 3b 3b st-port #f))..;;
3b70: 20 73 74 72 75 63 74 20 66 6f 72 20 6b 65 65 70 struct for keep
3b80: 69 6e 67 20 74 72 61 63 6b 20 6f 66 20 6f 74 68 ing track of oth
3b90: 65 72 73 20 77 65 20 61 72 65 20 74 61 6c 6b 69 ers we are talki
3ba0: 6e 67 20 74 6f 0a 0a 28 64 65 66 73 74 72 75 63 ng to..(defstruc
3bb0: 74 20 70 65 65 72 0a 20 20 28 61 64 64 72 2d 70 t peer. (addr-p
3bc0: 6f 72 74 20 20 20 20 20 20 20 23 66 29 0a 20 20 ort #f).
3bd0: 28 68 6f 73 74 6e 61 6d 65 20 20 20 20 20 20 20 (hostname
3be0: 20 23 66 29 0a 20 20 28 70 69 64 20 20 20 20 20 #f). (pid
3bf0: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 3b 3b #f). ;;
3c00: 20 28 69 6e 70 20 20 20 20 20 20 20 20 20 20 20 (inp
3c10: 20 20 23 66 29 0a 20 20 3b 3b 20 28 6f 75 70 20 #f). ;; (oup
3c20: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a #f).
3c30: 20 20 28 64 62 73 20 20 20 20 20 20 20 20 20 20 (dbs
3c40: 20 20 27 28 29 29 20 3b 3b 20 6c 69 73 74 20 6f '()) ;; list o
3c50: 66 20 64 61 74 61 62 61 73 65 73 20 74 68 69 73 f databases this
3c60: 20 70 65 65 72 20 69 73 20 63 75 72 72 65 6e 74 peer is current
3c70: 6c 79 20 68 61 6e 64 6c 69 6e 67 0a 20 20 29 0a ly handling. ).
3c80: 0a 28 64 65 66 73 74 72 75 63 74 20 77 6f 72 6b .(defstruct work
3c90: 0a 20 20 28 70 65 65 72 2d 64 61 74 20 20 20 23 . (peer-dat #
3ca0: 66 29 0a 20 20 28 68 61 6e 64 6c 65 72 6b 65 79 f). (handlerkey
3cb0: 20 23 66 29 0a 20 20 28 71 72 79 6b 65 79 20 20 #f). (qrykey
3cc0: 20 20 20 23 66 29 0a 20 20 28 64 61 74 61 20 20 #f). (data
3cd0: 20 20 20 20 20 23 66 29 0a 20 20 28 73 74 61 72 #f). (star
3ce0: 74 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d t (current-
3cf0: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a milliseconds))).
3d00: 0a 23 3b 28 64 65 66 73 74 72 75 63 74 20 64 62 .#;(defstruct db
3d10: 6f 77 6e 65 72 0a 20 20 28 70 64 61 74 20 20 20 owner. (pdat
3d20: 20 20 20 20 20 23 66 29 0a 20 20 28 6c 61 73 74 #f). (last
3d30: 2d 75 70 64 61 74 65 20 28 63 75 72 72 65 6e 74 -update (current
3d40: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 0a 3b 3b 3d -seconds)))..;;=
3d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d90: 3d 3d 3d 3d 3d 0a 3b 3b 20 43 61 70 74 61 69 6e =====.;; Captain
3da0: 20 66 75 6e 63 74 69 6f 6e 73 0a 3b 3b 3d 3d 3d functions.;;===
3db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3df0: 3d 3d 3d 0a 0a 3b 3b 20 4e 42 2f 2f 20 54 68 69 ===..;; NB// Thi
3e00: 73 20 6e 65 65 64 73 20 74 6f 20 62 65 20 73 74 s needs to be st
3e10: 61 72 74 65 64 20 69 6e 20 61 20 74 68 72 65 61 arted in a threa
3e20: 64 0a 3b 3b 0a 3b 3b 20 73 65 74 75 70 20 74 6f d.;;.;; setup to
3e30: 20 62 65 20 61 20 63 61 70 74 61 69 6e 0a 3b 3b be a captain.;;
3e40: 20 20 20 2d 20 6c 6f 63 61 6c 20 73 65 72 76 65 - local serve
3e50: 72 20 4d 55 53 54 20 62 65 20 73 74 61 72 74 65 r MUST be starte
3e60: 64 20 61 6c 72 65 61 64 79 0a 3b 3b 20 20 20 2d d already.;; -
3e70: 20 63 72 65 61 74 65 20 70 6b 74 0a 3b 3b 20 20 create pkt.;;
3e80: 20 2d 20 73 74 61 72 74 20 73 65 72 76 65 72 20 - start server
3e90: 70 6f 72 74 20 68 61 6e 64 6c 65 72 0a 3b 3b 0a port handler.;;.
3ea0: 28 64 65 66 69 6e 65 20 28 73 65 74 75 70 2d 61 (define (setup-a
3eb0: 73 2d 63 61 70 74 61 69 6e 20 75 64 61 74 61 29 s-captain udata)
3ec0: 0a 20 20 28 69 66 20 28 63 72 65 61 74 65 2d 63 . (if (create-c
3ed0: 61 70 74 61 69 6e 2d 70 6b 74 20 75 64 61 74 61 aptain-pkt udata
3ee0: 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ). (let* ((
3ef0: 6d 79 2d 61 64 64 72 20 28 75 64 61 74 2d 6d 79 my-addr (udat-my
3f00: 2d 61 64 64 72 65 73 73 20 75 64 61 74 61 29 29 -address udata))
3f10: 0a 09 20 20 20 20 20 28 6d 79 2d 70 6f 72 74 20 .. (my-port
3f20: 28 75 64 61 74 2d 6d 79 2d 70 6f 72 74 20 20 20 (udat-my-port
3f30: 20 75 64 61 74 61 29 29 0a 09 20 20 20 20 20 28 udata)).. (
3f40: 74 68 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 th (make-thread
3f50: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 28 (lambda ().....(
3f60: 75 6c 65 78 2d 68 61 6e 64 6c 65 72 2d 6c 6f 6f ulex-handler-loo
3f70: 70 20 75 64 61 74 61 29 29 20 22 43 61 70 74 61 p udata)) "Capta
3f80: 69 6e 20 68 61 6e 64 6c 65 72 22 29 29 29 0a 09 in handler")))..
3f90: 28 75 64 61 74 2d 68 61 6e 64 6c 65 72 2d 74 68 (udat-handler-th
3fa0: 72 65 61 64 2d 73 65 74 21 20 75 64 61 74 61 20 read-set! udata
3fb0: 74 68 29 0a 09 28 75 64 61 74 2d 63 61 70 74 61 th)..(udat-capta
3fc0: 69 6e 2d 61 64 64 72 65 73 73 2d 73 65 74 21 20 in-address-set!
3fd0: 75 64 61 74 61 20 6d 79 2d 61 64 64 72 29 0a 09 udata my-addr)..
3fe0: 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 70 6f (udat-captain-po
3ff0: 72 74 2d 73 65 74 21 20 20 20 20 75 64 61 74 61 rt-set! udata
4000: 20 6d 79 2d 70 6f 72 74 29 0a 09 28 74 68 72 65 my-port)..(thre
4010: 61 64 2d 73 74 61 72 74 21 20 74 68 29 29 0a 20 ad-start! th)).
4020: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 70 72 (begin..(pr
4030: 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 61 69 6c int "ERROR: fail
4040: 65 64 20 74 6f 20 63 72 65 61 74 65 20 63 61 70 ed to create cap
4050: 74 61 69 6e 20 70 6b 74 22 29 0a 09 23 66 29 29 tain pkt")..#f))
4060: 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 20 70 6b )..;; given a pk
4070: 74 73 20 64 69 72 20 72 65 61 64 20 0a 3b 3b 0a ts dir read .;;.
4080: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 61 6c 6c (define (get-all
4090: 2d 63 61 70 74 61 69 6e 2d 70 6b 74 73 20 75 64 -captain-pkts ud
40a0: 61 74 61 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 ata). (let* ((p
40b0: 6b 74 73 64 69 72 20 20 20 20 20 20 20 28 6c 65 ktsdir (le
40c0: 74 20 28 28 64 20 28 75 64 61 74 2d 63 70 6b 74 t ((d (udat-cpkt
40d0: 73 2d 64 69 72 20 75 64 61 74 61 29 29 29 0a 09 s-dir udata)))..
40e0: 09 09 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 .. (if (file-ex
40f0: 69 73 74 73 3f 20 64 29 0a 09 09 09 20 20 20 20 ists? d)....
4100: 20 20 64 0a 09 09 09 20 20 20 20 20 20 28 62 65 d.... (be
4110: 67 69 6e 0a 09 09 09 09 28 63 72 65 61 74 65 2d gin.....(create-
4120: 64 69 72 65 63 74 6f 72 79 20 64 20 23 74 29 0a directory d #t).
4130: 09 09 09 09 64 29 29 29 29 0a 09 20 28 61 6c 6c ....d)))).. (all
4140: 2d 70 6b 74 2d 66 69 6c 65 73 20 28 67 6c 6f 62 -pkt-files (glob
4150: 20 28 63 6f 6e 63 20 70 6b 74 73 64 69 72 20 22 (conc pktsdir "
4160: 2f 2a 2e 70 6b 74 22 29 29 29 0a 09 20 28 70 6b /*.pkt"))).. (pk
4170: 74 2d 73 70 65 63 20 20 20 20 20 20 28 75 64 61 t-spec (uda
4180: 74 2d 63 70 6b 74 2d 73 70 65 63 20 75 64 61 74 t-cpkt-spec udat
4190: 61 29 29 29 0a 20 20 20 20 28 6d 61 70 20 28 6c a))). (map (l
41a0: 61 6d 62 64 61 20 28 70 6b 74 2d 66 69 6c 65 29 ambda (pkt-file)
41b0: 0a 09 20 20 20 28 72 65 61 64 2d 70 6b 74 2d 3e .. (read-pkt->
41c0: 61 6c 69 73 74 20 70 6b 74 2d 66 69 6c 65 20 70 alist pkt-file p
41d0: 6b 74 73 70 65 63 3a 20 70 6b 74 2d 73 70 65 63 ktspec: pkt-spec
41e0: 29 29 0a 09 20 61 6c 6c 2d 70 6b 74 2d 66 69 6c )).. all-pkt-fil
41f0: 65 73 29 29 29 0a 0a 3b 3b 20 73 6f 72 74 20 62 es)))..;; sort b
4200: 79 20 44 20 74 68 65 6e 20 5a 2c 20 72 65 74 75 y D then Z, retu
4210: 72 6e 20 6f 6e 65 2c 20 63 68 6f 6f 73 65 20 74 rn one, choose t
4220: 68 65 20 6f 6c 64 65 73 74 20 74 68 65 6e 0a 3b he oldest then.;
4230: 3b 20 64 69 66 66 65 72 65 6e 74 69 61 74 65 20 ; differentiate
4240: 69 66 20 6e 65 65 64 65 64 20 75 73 69 6e 67 20 if needed using
4250: 74 68 65 20 5a 20 6b 65 79 0a 3b 3b 6c 0a 28 64 the Z key.;;l.(d
4260: 65 66 69 6e 65 20 28 67 65 74 2d 77 69 6e 6e 69 efine (get-winni
4270: 6e 67 2d 70 6b 74 20 70 6b 74 73 29 0a 20 20 28 ng-pkt pkts). (
4280: 69 66 20 28 6e 75 6c 6c 3f 20 70 6b 74 73 29 0a if (null? pkts).
4290: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
42a0: 63 61 72 20 28 73 6f 72 74 20 70 6b 74 73 20 28 car (sort pkts (
42b0: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 09 lambda (a b)....
42c0: 28 6c 65 74 20 28 28 61 64 20 28 73 74 72 69 6e (let ((ad (strin
42d0: 67 2d 3e 6e 75 6d 62 65 72 20 28 61 6c 69 73 74 g->number (alist
42e0: 2d 72 65 66 20 27 44 20 61 29 29 29 0a 09 09 09 -ref 'D a)))....
42f0: 20 20 20 20 20 20 28 62 64 20 28 73 74 72 69 6e (bd (strin
4300: 67 2d 3e 6e 75 6d 62 65 72 20 28 61 6c 69 73 74 g->number (alist
4310: 2d 72 65 66 20 27 44 20 62 29 29 29 29 0a 09 09 -ref 'D b))))...
4320: 09 20 20 28 69 66 20 28 65 71 3f 20 61 20 62 29 . (if (eq? a b)
4330: 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
4340: 28 61 7a 20 28 61 6c 69 73 74 2d 72 65 66 20 27 (az (alist-ref '
4350: 5a 20 61 29 29 0a 09 09 09 09 20 20 20 20 28 62 Z a))..... (b
4360: 7a 20 28 61 6c 69 73 74 2d 72 65 66 20 27 5a 20 z (alist-ref 'Z
4370: 62 29 29 29 0a 09 09 09 09 28 73 74 72 69 6e 67 b))).....(string
4380: 3e 3d 3f 20 61 7a 20 62 7a 29 29 0a 09 09 09 20 >=? az bz))....
4390: 20 20 20 20 20 28 3e 20 61 64 20 62 64 29 29 29 (> ad bd)))
43a0: 29 29 29 29 29 0a 0a 3b 3b 20 70 75 74 20 74 68 )))))..;; put th
43b0: 65 20 68 6f 73 74 2c 20 69 70 2c 20 70 6f 72 74 e host, ip, port
43c0: 20 61 6e 64 20 70 69 64 20 69 6e 74 6f 20 61 20 and pid into a
43d0: 70 6b 74 20 69 6e 0a 3b 3b 20 74 68 65 20 63 61 pkt in.;; the ca
43e0: 70 74 61 69 6e 20 70 6b 74 73 20 64 69 72 0a 3b ptain pkts dir.;
43f0: 3b 20 20 2d 20 61 73 73 75 6d 65 73 20 75 73 65 ; - assumes use
4400: 72 20 68 61 73 20 61 6c 72 65 61 64 79 20 66 69 r has already fi
4410: 72 65 64 20 75 70 20 61 20 73 65 72 76 65 72 0a red up a server.
4420: 3b 3b 20 20 20 20 77 68 69 63 68 20 77 69 6c 6c ;; which will
4430: 20 62 65 20 69 6e 20 74 68 65 20 75 64 61 74 61 be in the udata
4440: 20 73 74 72 75 63 74 0a 3b 3b 0a 28 64 65 66 69 struct.;;.(defi
4450: 6e 65 20 28 63 72 65 61 74 65 2d 63 61 70 74 61 ne (create-capta
4460: 69 6e 2d 70 6b 74 20 75 64 61 74 61 29 0a 20 20 in-pkt udata).
4470: 28 69 66 20 28 6e 6f 74 20 28 75 64 61 74 2d 73 (if (not (udat-s
4480: 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 75 64 61 erv-listener uda
4490: 74 61 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 ta)). (begi
44a0: 6e 0a 09 28 70 72 69 6e 74 20 22 45 52 52 4f 52 n..(print "ERROR
44b0: 3a 20 63 72 65 61 74 65 2d 63 61 70 74 61 69 6e : create-captain
44c0: 2d 70 6b 74 20 63 61 6c 6c 65 64 20 77 69 74 68 -pkt called with
44d0: 20 6f 75 74 20 61 20 6c 69 73 74 65 6e 65 72 22 out a listener"
44e0: 29 0a 09 23 66 29 0a 20 20 20 20 20 20 28 6c 65 )..#f). (le
44f0: 74 2a 20 28 28 70 6b 74 64 61 74 20 60 28 28 70 t* ((pktdat `((p
4500: 6f 72 74 20 20 20 2e 20 2c 28 75 64 61 74 2d 6d ort . ,(udat-m
4510: 79 2d 70 6f 72 74 20 75 64 61 74 61 29 29 0a 09 y-port udata))..
4520: 09 20 20 20 20 20 20 20 28 68 6f 73 74 20 20 20 . (host
4530: 2e 20 2c 28 75 64 61 74 2d 6d 79 2d 68 6f 73 74 . ,(udat-my-host
4540: 6e 61 6d 65 20 75 64 61 74 61 29 29 0a 09 09 20 name udata))...
4550: 20 20 20 20 20 20 28 69 70 61 64 64 72 20 2e 20 (ipaddr .
4560: 2c 28 75 64 61 74 2d 6d 79 2d 61 64 64 72 65 73 ,(udat-my-addres
4570: 73 20 75 64 61 74 61 29 29 0a 09 09 20 20 20 20 s udata))...
4580: 20 20 20 28 70 69 64 20 20 20 20 2e 20 2c 28 75 (pid . ,(u
4590: 64 61 74 2d 6d 79 2d 70 69 64 20 20 20 20 20 75 dat-my-pid u
45a0: 64 61 74 61 29 29 29 29 0a 09 20 20 20 20 20 28 data)))).. (
45b0: 70 6b 74 64 69 72 20 20 28 75 64 61 74 2d 63 70 pktdir (udat-cp
45c0: 6b 74 73 2d 64 69 72 20 75 64 61 74 61 29 29 0a kts-dir udata)).
45d0: 09 20 20 20 20 20 28 70 6b 74 73 70 65 63 20 28 . (pktspec (
45e0: 75 64 61 74 2d 63 70 6b 74 2d 73 70 65 63 20 75 udat-cpkt-spec u
45f0: 64 61 74 61 29 29 0a 09 20 20 20 20 20 29 0a 09 data)).. )..
4600: 28 75 64 61 74 2d 6d 79 2d 63 70 6b 74 2d 6b 65 (udat-my-cpkt-ke
4610: 79 2d 73 65 74 21 0a 09 20 75 64 61 74 61 0a 09 y-set!.. udata..
4620: 20 28 77 72 69 74 65 2d 61 6c 69 73 74 2d 3e 70 (write-alist->p
4630: 6b 74 0a 09 20 20 70 6b 74 64 69 72 0a 09 20 20 kt.. pktdir..
4640: 70 6b 74 64 61 74 0a 09 20 20 70 6b 74 73 70 65 pktdat.. pktspe
4650: 63 3a 20 70 6b 74 73 70 65 63 0a 09 20 20 70 74 c: pktspec.. pt
4660: 79 70 65 3a 20 20 20 27 63 61 70 74 61 69 6e 29 ype: 'captain)
4670: 29 0a 09 28 75 64 61 74 2d 6d 79 2d 63 70 6b 74 )..(udat-my-cpkt
4680: 2d 6b 65 79 20 75 64 61 74 61 29 29 29 29 0a 0a -key udata))))..
4690: 3b 3b 20 72 65 6d 6f 76 65 20 70 6b 74 20 61 73 ;; remove pkt as
46a0: 73 6f 63 69 61 74 65 64 20 77 69 74 68 20 63 61 sociated with ca
46b0: 70 74 6e 20 28 74 68 65 20 5a 20 6b 65 79 20 2e ptn (the Z key .
46c0: 70 6b 74 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 pkt).;;.(define
46d0: 28 72 65 6d 6f 76 65 2d 63 61 70 74 61 69 6e 2d (remove-captain-
46e0: 70 6b 74 20 75 64 61 74 61 20 63 61 70 74 6e 29 pkt udata captn)
46f0: 0a 20 20 28 6c 65 74 20 28 28 5a 20 20 20 20 20 . (let ((Z
4700: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 5a 20 (alist-ref 'Z
4710: 63 61 70 74 6e 29 29 0a 09 28 63 70 6b 74 64 69 captn))..(cpktdi
4720: 72 20 28 75 64 61 74 2d 63 70 6b 74 73 2d 64 69 r (udat-cpkts-di
4730: 72 20 75 64 61 74 61 29 29 29 0a 20 20 20 20 28 r udata))). (
4740: 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 28 63 6f delete-file* (co
4750: 6e 63 20 63 70 6b 74 64 69 72 20 22 2f 22 20 5a nc cpktdir "/" Z
4760: 20 22 2e 70 6b 74 22 29 29 29 29 0a 0a 3b 3b 20 ".pkt"))))..;;
4770: 63 61 6c 6c 20 61 6c 6c 20 6b 6e 6f 77 6e 20 70 call all known p
4780: 65 65 72 73 20 61 6e 64 20 74 65 6c 6c 20 74 68 eers and tell th
4790: 65 6d 20 74 6f 20 64 65 6c 65 74 65 20 74 68 65 em to delete the
47a0: 69 72 20 69 6e 66 6f 20 6f 6e 20 74 68 65 20 63 ir info on the c
47b0: 61 70 74 61 69 6e 0a 3b 3b 20 74 68 75 73 20 66 aptain.;; thus f
47c0: 6f 72 63 69 6e 67 20 74 68 65 6d 20 74 6f 20 72 orcing them to r
47d0: 65 2d 72 65 61 64 20 70 6b 74 73 20 61 6e 64 20 e-read pkts and
47e0: 63 6f 6e 6e 65 63 74 20 74 6f 20 61 20 6e 65 77 connect to a new
47f0: 20 63 61 70 74 61 69 6e 0a 3b 3b 20 63 61 6c 6c captain.;; call
4800: 20 74 68 69 73 20 77 68 65 6e 20 74 68 65 20 63 this when the c
4810: 61 70 74 61 69 6e 20 6e 65 65 64 73 20 74 6f 20 aptain needs to
4820: 65 78 69 74 20 61 6e 64 20 69 66 20 61 6e 20 6f exit and if an o
4830: 6c 64 65 72 20 63 61 70 74 61 69 6e 20 69 73 0a lder captain is.
4840: 3b 3b 20 64 65 74 65 63 74 65 64 2e 20 44 75 65 ;; detected. Due
4850: 20 74 6f 20 64 65 6c 61 79 73 20 69 6e 20 73 65 to delays in se
4860: 6e 64 69 6e 67 20 66 69 6c 65 20 6d 65 74 61 20 nding file meta
4870: 64 61 74 61 20 69 6e 20 4e 46 53 20 6d 75 6c 74 data in NFS mult
4880: 69 70 6c 65 0a 3b 3b 20 63 61 70 74 61 69 6e 73 iple.;; captains
4890: 20 63 61 6e 20 62 65 20 69 6e 69 74 69 61 74 65 can be initiate
48a0: 64 20 69 6e 20 61 20 22 53 74 6f 72 6d 20 6f 66 d in a "Storm of
48b0: 20 43 61 70 74 61 69 6e 73 22 2c 20 62 6f 6f 6b Captains", book
48c0: 20 73 6f 6f 6e 20 74 6f 20 62 65 0a 3b 3b 20 6f soon to be.;; o
48d0: 6e 20 41 6d 61 7a 6f 6e 0a 3b 3b 0a 28 64 65 66 n Amazon.;;.(def
48e0: 69 6e 65 20 28 64 72 6f 70 2d 63 61 70 74 61 69 ine (drop-captai
48f0: 6e 20 75 64 61 74 61 29 0a 20 20 28 6c 65 74 2a n udata). (let*
4900: 20 28 28 70 65 65 72 73 20 28 68 61 73 68 2d 74 ((peers (hash-t
4910: 61 62 6c 65 2d 6b 65 79 73 20 28 75 64 61 74 2d able-keys (udat-
4920: 70 65 65 72 73 20 75 64 61 74 61 29 29 29 0a 09 peers udata)))..
4930: 20 28 63 6f 6f 6b 69 65 20 28 6d 61 6b 65 2d 63 (cookie (make-c
4940: 6f 6f 6b 69 65 20 75 64 61 74 61 29 29 29 0a 20 ookie udata))).
4950: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
4960: 20 20 28 6c 61 6d 62 64 61 20 28 68 6f 73 74 2d (lambda (host-
4970: 70 6f 72 74 29 0a 20 20 20 20 20 20 20 28 73 65 port). (se
4980: 6e 64 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f nd udata host-po
4990: 72 74 20 27 64 72 6f 70 63 61 70 74 61 69 6e 20 rt 'dropcaptain
49a0: 63 6f 6f 6b 69 65 20 22 6e 6f 6d 73 67 22 20 72 cookie "nomsg" r
49b0: 65 74 76 61 6c 3a 20 23 74 29 29 0a 20 20 20 20 etval: #t)).
49c0: 20 70 65 65 72 73 29 29 29 0a 0a 3b 3b 3d 3d 3d peers)))..;;===
49d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a10: 3d 3d 3d 0a 3b 3b 20 73 65 72 76 65 72 20 70 72 ===.;; server pr
4a20: 69 6d 69 74 69 76 65 73 0a 3b 3b 3d 3d 3d 3d 3d imitives.;;=====
4a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a70: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 =..(define (make
4a80: 2d 63 6f 6f 6b 69 65 20 75 64 61 74 61 29 0a 20 -cookie udata).
4a90: 20 28 6c 65 74 20 28 28 6e 65 77 63 6e 75 6d 20 (let ((newcnum
4aa0: 28 2b 20 28 75 64 61 74 2d 63 6e 75 6d 20 75 64 (+ (udat-cnum ud
4ab0: 61 74 61 29 20 31 29 29 29 0a 20 20 20 20 28 75 ata) 1))). (u
4ac0: 64 61 74 2d 63 6e 75 6d 2d 73 65 74 21 20 75 64 dat-cnum-set! ud
4ad0: 61 74 61 20 6e 65 77 63 6e 75 6d 29 0a 20 20 20 ata newcnum).
4ae0: 20 28 63 6f 6e 63 20 28 75 64 61 74 2d 6d 79 2d (conc (udat-my-
4af0: 61 64 64 72 65 73 73 20 75 64 61 74 61 29 20 22 address udata) "
4b00: 3a 22 0a 09 20 20 28 75 64 61 74 2d 6d 79 2d 70 :".. (udat-my-p
4b10: 6f 72 74 20 20 20 20 75 64 61 74 61 29 20 22 2d ort udata) "-
4b20: 22 0a 09 20 20 28 75 64 61 74 2d 6d 79 2d 70 69 ".. (udat-my-pi
4b30: 64 20 20 20 20 20 75 64 61 74 61 29 20 22 2d 22 d udata) "-"
4b40: 0a 09 20 20 6e 65 77 63 6e 75 6d 29 29 29 0a 0a .. newcnum)))..
4b50: 3b 3b 20 63 72 65 61 74 65 20 61 20 74 63 70 20 ;; create a tcp
4b60: 6c 69 73 74 65 6e 65 72 20 61 6e 64 20 72 65 74 listener and ret
4b70: 75 72 6e 20 61 20 70 6f 70 75 6c 61 74 65 64 20 urn a populated
4b80: 75 64 61 74 20 73 74 72 75 63 74 20 77 69 74 68 udat struct with
4b90: 0a 3b 3b 20 6d 79 20 70 6f 72 74 2c 20 61 64 64 .;; my port, add
4ba0: 72 65 73 73 2c 20 68 6f 73 74 6e 61 6d 65 2c 20 ress, hostname,
4bb0: 70 69 64 20 65 74 63 2e 0a 3b 3b 20 72 65 74 75 pid etc..;; retu
4bc0: 72 6e 20 23 66 20 69 66 20 66 61 69 6c 20 74 6f rn #f if fail to
4bd0: 20 66 69 6e 64 20 61 20 70 6f 72 74 20 74 6f 20 find a port to
4be0: 61 6c 6c 6f 63 61 74 65 2e 0a 3b 3b 0a 3b 3b 20 allocate..;;.;;
4bf0: 20 69 66 20 75 64 61 74 61 2d 69 6e 20 69 73 20 if udata-in is
4c00: 23 66 20 63 72 65 61 74 65 20 74 68 65 20 72 65 #f create the re
4c10: 63 6f 72 64 0a 3b 3b 20 20 69 66 20 74 68 65 72 cord.;; if ther
4c20: 65 20 69 73 20 61 6c 72 65 61 64 79 20 61 20 73 e is already a s
4c30: 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 72 65 74 erv-listener ret
4c40: 75 72 6e 20 74 68 65 20 75 64 61 74 61 0a 3b 3b urn the udata.;;
4c50: 0a 28 64 65 66 69 6e 65 20 28 73 74 61 72 74 2d .(define (start-
4c60: 73 65 72 76 65 72 2d 66 69 6e 64 2d 70 6f 72 74 server-find-port
4c70: 20 75 64 61 74 61 2d 69 6e 20 23 21 6f 70 74 69 udata-in #!opti
4c80: 6f 6e 61 6c 20 28 70 6f 72 74 20 34 32 34 32 29 onal (port 4242)
4c90: 29 0a 20 20 28 6c 65 74 20 28 28 75 64 61 74 61 ). (let ((udata
4ca0: 20 28 6f 72 20 75 64 61 74 61 2d 69 6e 20 28 6d (or udata-in (m
4cb0: 61 6b 65 2d 75 64 61 74 29 29 29 29 0a 20 20 20 ake-udat)))).
4cc0: 20 28 69 66 20 28 75 64 61 74 2d 73 65 72 76 2d (if (udat-serv-
4cd0: 6c 69 73 74 65 6e 65 72 20 75 64 61 74 61 29 20 listener udata)
4ce0: 3b 3b 20 54 4f 44 4f 20 2d 20 61 64 64 20 63 68 ;; TODO - add ch
4cf0: 65 63 6b 20 74 68 61 74 20 74 68 65 20 6c 69 73 eck that the lis
4d00: 74 65 6e 65 72 20 69 73 20 61 6c 69 76 65 20 61 tener is alive a
4d10: 6e 64 20 72 65 61 64 79 3f 0a 09 75 64 61 74 61 nd ready?..udata
4d20: 0a 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 ..(handle-except
4d30: 69 6f 6e 73 0a 09 20 20 20 20 65 78 6e 0a 09 20 ions.. exn..
4d40: 20 28 69 66 20 28 3c 20 70 6f 72 74 20 36 35 35 (if (< port 655
4d50: 33 35 29 0a 09 20 20 20 20 20 20 28 73 74 61 72 35).. (star
4d60: 74 2d 73 65 72 76 65 72 2d 66 69 6e 64 2d 70 6f t-server-find-po
4d70: 72 74 20 75 64 61 74 61 20 28 2b 20 70 6f 72 74 rt udata (+ port
4d80: 20 31 29 29 0a 09 20 20 20 20 20 20 23 66 29 0a 1)).. #f).
4d90: 09 20 20 28 63 6f 6e 6e 65 63 74 2d 73 65 72 76 . (connect-serv
4da0: 65 72 20 75 64 61 74 61 20 70 6f 72 74 29 29 29 er udata port)))
4db0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e ))..(define (con
4dc0: 6e 65 63 74 2d 73 65 72 76 65 72 20 75 64 61 74 nect-server udat
4dd0: 61 20 70 6f 72 74 29 0a 20 20 3b 3b 20 28 74 63 a port). ;; (tc
4de0: 70 2d 6c 69 73 74 65 6e 65 72 2d 73 6f 63 6b 65 p-listener-socke
4df0: 74 20 4c 49 53 54 45 4e 45 52 29 28 73 6f 63 6b t LISTENER)(sock
4e00: 65 74 2d 6e 61 6d 65 20 73 6f 29 0a 20 20 3b 3b et-name so). ;;
4e10: 20 73 6f 63 6b 61 64 64 72 2d 61 64 64 72 65 73 sockaddr-addres
4e20: 73 2c 20 73 6f 63 6b 61 64 64 72 2d 70 6f 72 74 s, sockaddr-port
4e30: 2c 20 73 6f 63 6b 61 64 64 72 2d 3e 73 74 72 69 , sockaddr->stri
4e40: 6e 67 0a 20 20 28 6c 65 74 2a 20 28 28 74 6c 73 ng. (let* ((tls
4e50: 6e 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 70 6f n (tcp-listen po
4e60: 72 74 20 31 30 30 30 20 23 66 29 29 20 3b 3b 20 rt 1000 #f)) ;;
4e70: 28 74 63 70 2d 6c 69 73 74 65 6e 20 54 43 50 50 (tcp-listen TCPP
4e80: 4f 52 54 20 5b 42 41 43 4b 4c 4f 47 20 5b 48 4f ORT [BACKLOG [HO
4e90: 53 54 5d 5d 29 0a 09 20 28 61 64 64 72 20 28 67 ST]]).. (addr (g
4ea0: 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 et-my-best-addre
4eb0: 73 73 29 29 29 20 3b 3b 20 28 68 6f 73 74 69 6e ss))) ;; (hostin
4ec0: 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f fo-addresses (ho
4ed0: 73 74 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 st-information (
4ee0: 63 75 72 72 65 6e 74 2d 68 6f 73 74 6e 61 6d 65 current-hostname
4ef0: 29 29 29 0a 20 20 20 20 28 75 64 61 74 2d 6d 79 ))). (udat-my
4f00: 2d 61 64 64 72 65 73 73 2d 73 65 74 21 20 20 20 -address-set!
4f10: 20 75 64 61 74 61 20 61 64 64 72 29 0a 20 20 20 udata addr).
4f20: 20 28 75 64 61 74 2d 6d 79 2d 70 6f 72 74 2d 73 (udat-my-port-s
4f30: 65 74 21 20 20 20 20 20 20 20 75 64 61 74 61 20 et! udata
4f40: 70 6f 72 74 29 0a 20 20 20 20 28 75 64 61 74 2d port). (udat-
4f50: 6d 79 2d 68 6f 73 74 6e 61 6d 65 2d 73 65 74 21 my-hostname-set!
4f60: 20 20 20 75 64 61 74 61 20 28 67 65 74 2d 68 6f udata (get-ho
4f70: 73 74 2d 6e 61 6d 65 29 29 0a 20 20 20 20 28 75 st-name)). (u
4f80: 64 61 74 2d 73 65 72 76 2d 6c 69 73 74 65 6e 65 dat-serv-listene
4f90: 72 2d 73 65 74 21 20 75 64 61 74 61 20 74 6c 73 r-set! udata tls
4fa0: 6e 29 0a 20 20 20 20 75 64 61 74 61 29 29 0a 0a n). udata))..
4fb0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 70 65 65 (define (get-pee
4fc0: 72 2d 64 61 74 20 75 64 61 74 61 20 68 6f 73 74 r-dat udata host
4fd0: 2d 70 6f 72 74 20 23 21 6f 70 74 69 6f 6e 61 6c -port #!optional
4fe0: 20 28 68 6f 73 74 6e 61 6d 65 20 23 66 29 28 70 (hostname #f)(p
4ff0: 69 64 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 id #f)). (let*
5000: 28 28 70 64 61 74 20 28 6f 72 20 28 75 64 61 74 ((pdat (or (udat
5010: 2d 67 65 74 2d 70 65 65 72 20 75 64 61 74 61 20 -get-peer udata
5020: 68 6f 73 74 2d 70 6f 72 74 29 0a 09 09 20 20 20 host-port)...
5030: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
5040: 6e 73 20 3b 3b 20 45 52 52 4f 52 20 2d 20 4d 41 ns ;; ERROR - MA
5050: 4b 45 20 54 48 49 53 20 45 58 43 45 50 54 49 4f KE THIS EXCEPTIO
5060: 4e 20 48 41 4e 44 4c 45 52 20 4d 4f 52 45 20 53 N HANDLER MORE S
5070: 50 45 43 49 46 49 43 0a 09 09 20 20 20 20 65 78 PECIFIC... ex
5080: 6e 0a 09 09 20 20 20 20 23 66 0a 09 09 20 20 20 n... #f...
5090: 20 28 6c 65 74 20 28 28 6e 70 64 61 74 20 28 6d (let ((npdat (m
50a0: 61 6b 65 2d 70 65 65 72 20 61 64 64 72 2d 70 6f ake-peer addr-po
50b0: 72 74 3a 20 68 6f 73 74 2d 70 6f 72 74 29 29 29 rt: host-port)))
50c0: 0a 09 09 20 20 20 20 20 20 28 69 66 20 68 6f 73 ... (if hos
50d0: 74 6e 61 6d 65 20 28 70 65 65 72 2d 68 6f 73 74 tname (peer-host
50e0: 6e 61 6d 65 2d 73 65 74 21 20 6e 70 64 61 74 20 name-set! npdat
50f0: 68 6f 73 74 6e 61 6d 65 29 29 0a 09 09 20 20 20 hostname))...
5100: 20 20 20 28 69 66 20 70 69 64 20 28 70 65 65 72 (if pid (peer
5110: 2d 70 69 64 2d 73 65 74 21 20 6e 70 64 61 74 20 -pid-set! npdat
5120: 70 69 64 29 29 0a 09 09 20 20 20 20 20 20 6e 70 pid))... np
5130: 64 61 74 29 29 29 29 29 0a 20 20 20 20 70 64 61 dat))))). pda
5140: 74 29 29 0a 0a 3b 3b 20 73 65 6e 64 20 73 74 72 t))..;; send str
5150: 75 63 74 75 72 65 64 20 64 61 74 61 20 74 6f 20 uctured data to
5160: 72 65 63 69 70 69 65 6e 74 0a 3b 3b 0a 3b 3b 20 recipient.;;.;;
5170: 20 4e 4f 54 45 3a 20 71 72 79 6b 65 79 20 69 73 NOTE: qrykey is
5180: 20 77 68 61 74 20 77 61 73 20 63 61 6c 6c 65 64 what was called
5190: 20 74 68 65 20 22 63 6f 6f 6b 69 65 22 20 70 72 the "cookie" pr
51a0: 65 76 69 6f 75 73 6c 79 0a 3b 3b 0a 3b 3b 20 20 eviously.;;.;;
51b0: 20 20 20 72 65 74 76 61 6c 20 74 65 6c 6c 73 20 retval tells
51c0: 73 65 6e 64 20 74 6f 20 65 78 70 65 63 74 20 61 send to expect a
51d0: 6e 64 20 77 61 69 74 20 66 6f 72 20 72 65 74 75 nd wait for retu
51e0: 72 6e 20 64 61 74 61 20 28 6f 6e 65 20 6c 69 6e rn data (one lin
51f0: 65 29 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 e) and return it
5200: 20 6f 72 20 74 69 6d 65 20 6f 75 74 0a 3b 3b 20 or time out.;;
5210: 20 20 20 20 20 20 74 68 69 73 20 69 73 20 66 6f this is fo
5220: 72 20 70 69 6e 67 20 77 68 65 72 65 20 77 65 20 r ping where we
5230: 64 6f 6e 27 74 20 77 61 6e 74 20 74 6f 20 6e 65 don't want to ne
5240: 63 65 73 73 61 72 69 6c 79 20 68 61 76 65 20 73 cessarily have s
5250: 65 74 20 75 70 20 6f 75 72 20 6f 77 6e 20 73 65 et up our own se
5260: 72 76 65 72 20 79 65 74 2e 0a 3b 3b 0a 28 64 65 rver yet..;;.(de
5270: 66 69 6e 65 20 28 73 65 6e 64 20 75 64 61 74 61 fine (send udata
5280: 20 68 6f 73 74 2d 70 6f 72 74 20 68 61 6e 64 6c host-port handl
5290: 65 72 20 71 72 79 6b 65 79 20 64 61 74 61 0a 09 er qrykey data..
52a0: 20 20 20 20 20 20 23 21 6b 65 79 20 28 68 6f 73 #!key (hos
52b0: 74 6e 61 6d 65 20 23 66 29 28 70 69 64 20 23 66 tname #f)(pid #f
52c0: 29 28 70 61 72 61 6d 73 20 27 28 29 29 28 72 65 )(params '())(re
52d0: 74 76 61 6c 20 23 66 29 29 0a 20 20 28 6c 65 74 tval #f)). (let
52e0: 2a 20 28 28 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 * ((my-host-port
52f0: 20 28 75 64 61 74 2d 6d 79 2d 68 6f 73 74 2d 70 (udat-my-host-p
5300: 6f 72 74 20 75 64 61 74 61 29 29 0a 09 20 28 69 ort udata)).. (i
5310: 73 6d 65 20 20 20 20 20 20 20 20 20 28 65 71 75 sme (equ
5320: 61 6c 3f 20 68 6f 73 74 2d 70 6f 72 74 20 6d 79 al? host-port my
5330: 2d 68 6f 73 74 2d 70 6f 72 74 29 29 20 3b 3b 20 -host-port)) ;;
5340: 61 6d 20 49 20 63 61 6c 6c 69 6e 67 0a 09 09 09 am I calling....
5350: 09 09 09 09 3b 3b 20 6d 79 73 65 6c 66 3f 0a 09 ....;; myself?..
5360: 20 28 64 61 74 20 20 20 20 20 20 20 20 20 20 28 (dat (
5370: 6c 69 73 74 0a 09 09 09 68 61 6e 64 6c 65 72 20 list....handler
5380: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
5390: 22 20 22 0a 09 09 09 6d 79 2d 68 6f 73 74 2d 70 " "....my-host-p
53a0: 6f 72 74 20 20 20 20 20 20 20 20 20 3b 3b 20 22 ort ;; "
53b0: 20 22 0a 09 09 09 28 75 64 61 74 2d 6d 79 2d 70 "....(udat-my-p
53c0: 69 64 20 20 75 64 61 74 61 29 20 3b 3b 20 22 20 id udata) ;; "
53d0: 22 0a 09 09 09 71 72 79 6b 65 79 0a 09 09 09 70 "....qrykey....p
53e0: 61 72 61 6d 73 20 3b 3b 28 69 66 20 28 6e 75 6c arams ;;(if (nul
53f0: 6c 3f 20 70 61 72 61 6d 73 29 20 22 22 20 28 63 l? params) "" (c
5400: 6f 6e 63 20 22 20 22 0a 09 09 09 20 20 20 20 20 onc " "....
5410: 20 20 3b 3b 28 73 74 72 69 6e 67 2d 69 6e 74 65 ;;(string-inte
5420: 72 73 70 65 72 73 65 20 70 61 72 61 6d 73 20 22 rsperse params "
5430: 20 22 29 29 29 0a 09 09 09 29 29 29 0a 20 20 20 ")))....))).
5440: 20 3b 3b 20 28 70 72 69 6e 74 20 22 73 65 6e 64 ;; (print "send
5450: 20 69 73 6d 65 20 69 73 20 22 20 28 69 66 20 69 isme is " (if i
5460: 73 6d 65 20 22 74 72 75 65 21 22 20 22 66 61 6c sme "true!" "fal
5470: 73 65 21 22 29 20 22 2c 0a 20 20 20 20 3b 3b 20 se!") ",. ;;
5480: 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 3a 20 22 20 my-host-port: "
5490: 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 20 22 2c 20 my-host-port ",
54a0: 68 6f 73 74 2d 70 6f 72 74 3a 20 22 20 68 6f 73 host-port: " hos
54b0: 74 2d 70 6f 72 74 29 0a 20 20 20 20 28 69 66 20 t-port). (if
54c0: 69 73 6d 65 0a 09 28 75 6c 65 78 2d 68 61 6e 64 isme..(ulex-hand
54d0: 6c 65 72 20 75 64 61 74 61 20 64 61 74 20 64 61 ler udata dat da
54e0: 74 61 29 0a 09 28 68 61 6e 64 6c 65 2d 65 78 63 ta)..(handle-exc
54f0: 65 70 74 69 6f 6e 73 20 3b 3b 20 45 52 52 4f 52 eptions ;; ERROR
5500: 20 2d 20 4d 41 4b 45 20 54 48 49 53 20 45 58 43 - MAKE THIS EXC
5510: 45 50 54 49 4f 4e 20 48 41 4e 44 4c 45 52 20 4d EPTION HANDLER M
5520: 4f 52 45 0a 09 09 09 20 20 20 3b 3b 20 53 50 45 ORE.... ;; SPE
5530: 43 49 46 49 43 0a 09 20 20 20 20 65 78 6e 0a 09 CIFIC.. exn..
5540: 20 20 20 20 23 66 20 0a 09 20 20 28 6c 65 74 2d #f .. (let-
5550: 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 6f 75 values (((inp ou
5560: 70 29 28 74 63 70 2d 63 6f 6e 6e 65 63 74 20 68 p)(tcp-connect h
5570: 6f 73 74 2d 70 6f 72 74 29 29 29 0a 09 20 20 20 ost-port)))..
5580: 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 43 4f 4e 54 ;;.. ;; CONT
5590: 52 4f 4c 20 4c 49 4e 45 3a 0a 09 20 20 20 20 3b ROL LINE:.. ;
55a0: 3b 20 20 20 20 68 61 6e 64 6c 65 72 6b 65 79 20 ; handlerkey
55b0: 68 6f 73 74 3a 70 6f 72 74 20 70 69 64 20 71 72 host:port pid qr
55c0: 79 6b 65 79 20 70 61 72 61 6d 73 20 2e 2e 2e 0a ykey params ....
55d0: 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 6c 65 . ;;.. (le
55e0: 74 20 28 28 72 65 73 0a 09 09 20 20 20 28 69 66 t ((res... (if
55f0: 20 28 61 6e 64 20 69 6e 70 20 6f 75 70 29 0a 09 (and inp oup)..
5600: 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 29 . (let* ()
5610: 0a 09 09 09 20 28 69 66 20 6d 79 2d 68 6f 73 74 .... (if my-host
5620: 2d 70 6f 72 74 0a 09 09 09 20 20 20 20 20 28 62 -port.... (b
5630: 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 egin.... (
5640: 77 72 69 74 65 20 64 61 74 20 20 6f 75 70 29 0a write dat oup).
5650: 09 09 09 20 20 20 20 20 20 20 28 77 72 69 74 65 ... (write
5660: 20 64 61 74 61 20 6f 75 70 29 20 3b 3b 20 73 65 data oup) ;; se
5670: 6e 64 20 61 73 20 73 65 78 70 72 0a 09 09 09 20 nd as sexpr....
5680: 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ;; (print
5690: 22 53 65 6e 74 20 64 61 74 3a 20 22 20 64 61 74 "Sent dat: " dat
56a0: 20 22 20 64 61 74 61 3a 20 22 20 64 61 74 61 29 " data: " data)
56b0: 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 72 .... (if r
56c0: 65 74 76 61 6c 0a 09 09 09 09 20 20 20 28 72 65 etval..... (re
56d0: 61 64 20 69 6e 70 29 0a 09 09 09 09 20 20 20 23 ad inp)..... #
56e0: 74 29 29 0a 09 09 09 20 20 20 20 20 28 62 65 67 t)).... (beg
56f0: 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 70 72 in.... (pr
5700: 69 6e 74 20 22 45 52 52 4f 52 3a 20 73 65 6e 64 int "ERROR: send
5710: 20 63 61 6c 6c 65 64 20 62 75 74 20 6e 6f 20 72 called but no r
5720: 65 63 65 69 76 65 72 20 68 61 73 20 62 65 65 6e eceiver has been
5730: 20 73 65 74 75 70 2e 20 50 6c 65 61 73 65 20 63 setup. Please c
5740: 61 6c 6c 20 73 65 74 75 70 20 66 69 72 73 74 21 all setup first!
5750: 22 29 0a 09 09 09 20 20 20 20 20 20 20 23 66 29 ").... #f)
5760: 29 0a 09 09 09 20 3b 3b 20 4e 4f 54 45 3a 20 44 ).... ;; NOTE: D
5770: 4f 20 4e 4f 54 20 42 45 20 54 45 4d 50 54 45 44 O NOT BE TEMPTED
5780: 20 54 4f 20 4c 4f 4f 4b 20 41 54 20 41 4e 59 20 TO LOOK AT ANY
5790: 44 41 54 41 20 4f 4e 20 49 4e 50 20 48 45 52 45 DATA ON INP HERE
57a0: 21 0a 09 09 09 20 3b 3b 20 20 20 20 20 20 20 28 !.... ;; (
57b0: 74 68 65 72 65 20 69 73 20 61 20 6c 69 73 74 65 there is a liste
57c0: 6e 65 72 20 66 6f 72 20 68 61 6e 64 6c 69 6e 67 ner for handling
57d0: 20 74 68 61 74 29 0a 09 09 09 20 29 0a 09 09 20 that).... )...
57e0: 20 20 20 20 20 20 23 66 29 29 29 20 3b 3b 20 23 #f))) ;; #
57f0: 66 20 6d 65 61 6e 73 20 66 61 69 6c 65 64 20 74 f means failed t
5800: 6f 20 63 6f 6e 6e 65 63 74 20 61 6e 64 20 73 65 o connect and se
5810: 6e 64 0a 09 20 20 20 20 20 20 28 63 6c 6f 73 65 nd.. (close
5820: 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 -input-port inp)
5830: 0a 09 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f .. (close-o
5840: 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a utput-port oup).
5850: 09 20 20 20 20 20 20 72 65 73 29 29 29 29 29 29 . res))))))
5860: 0a 0a 3b 3b 20 73 65 6e 64 20 61 20 72 65 71 75 ..;; send a requ
5870: 65 73 74 20 74 6f 20 74 68 65 20 67 69 76 65 6e est to the given
5880: 20 68 6f 73 74 2d 70 6f 72 74 20 61 6e 64 20 72 host-port and r
5890: 65 67 69 73 74 65 72 20 61 20 6d 61 69 6c 62 6f egister a mailbo
58a0: 78 20 69 6e 20 75 64 61 74 61 0a 3b 3b 20 77 61 x in udata.;; wa
58b0: 69 74 20 66 6f 72 20 74 68 65 20 6d 61 69 6c 62 it for the mailb
58c0: 6f 78 20 64 61 74 61 20 61 6e 64 20 72 65 74 75 ox data and retu
58d0: 72 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 rn it.;;.(define
58e0: 20 28 73 65 6e 64 2d 72 65 63 65 69 76 65 20 75 (send-receive u
58f0: 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 20 68 data host-port h
5900: 61 6e 64 6c 65 72 20 71 72 79 6b 65 79 20 64 61 andler qrykey da
5910: 74 61 20 23 21 6b 65 79 20 28 68 6f 73 74 6e 61 ta #!key (hostna
5920: 6d 65 20 23 66 29 28 70 69 64 20 23 66 29 28 70 me #f)(pid #f)(p
5930: 61 72 61 6d 73 20 27 28 29 29 28 74 69 6d 65 6f arams '())(timeo
5940: 75 74 20 32 30 29 29 0a 20 20 28 6c 65 74 20 28 ut 20)). (let (
5950: 28 6d 62 6f 78 20 20 20 20 20 20 28 6d 61 6b 65 (mbox (make
5960: 2d 6d 61 69 6c 62 6f 78 29 29 0a 09 28 6d 62 6f -mailbox))..(mbo
5970: 78 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d x-time (current-
5980: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 milliseconds))..
5990: 28 6d 62 6f 78 65 73 20 20 20 20 28 75 64 61 74 (mboxes (udat
59a0: 2d 6d 62 6f 78 65 73 20 75 64 61 74 61 29 29 29 -mboxes udata)))
59b0: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
59c0: 2d 73 65 74 21 20 6d 62 6f 78 65 73 20 71 72 79 -set! mboxes qry
59d0: 6b 65 79 20 6d 62 6f 78 29 0a 20 20 20 20 28 69 key mbox). (i
59e0: 66 20 28 73 65 6e 64 20 75 64 61 74 61 20 68 6f f (send udata ho
59f0: 73 74 2d 70 6f 72 74 20 68 61 6e 64 6c 65 72 20 st-port handler
5a00: 71 72 79 6b 65 79 20 64 61 74 61 20 68 6f 73 74 qrykey data host
5a10: 6e 61 6d 65 3a 20 68 6f 73 74 6e 61 6d 65 20 70 name: hostname p
5a20: 69 64 3a 20 70 69 64 20 70 61 72 61 6d 73 3a 20 id: pid params:
5a30: 70 61 72 61 6d 73 29 0a 09 28 6c 65 74 2a 20 28 params)..(let* (
5a40: 28 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d 73 65 (mbox-timeout-se
5a50: 63 73 20 20 20 20 74 69 6d 65 6f 75 74 29 0a 09 cs timeout)..
5a60: 20 20 20 20 20 20 20 28 6d 62 6f 78 2d 74 69 6d (mbox-tim
5a70: 65 6f 75 74 2d 72 65 73 75 6c 74 20 27 4d 42 4f eout-result 'MBO
5a80: 58 5f 54 49 4d 45 4f 55 54 29 0a 09 20 20 20 20 X_TIMEOUT)..
5a90: 20 20 20 28 72 65 73 20 20 20 20 20 20 20 20 20 (res
5aa0: 20 20 20 20 20 20 20 20 20 28 6d 61 69 6c 62 6f (mailbo
5ab0: 78 2d 72 65 63 65 69 76 65 21 20 6d 62 6f 78 20 x-receive! mbox
5ac0: 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d 73 65 63 mbox-timeout-sec
5ad0: 73 20 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d 72 s mbox-timeout-r
5ae0: 65 73 75 6c 74 29 29 0a 09 20 20 20 20 20 20 20 esult))..
5af0: 28 6d 62 6f 78 2d 72 65 63 65 69 76 65 2d 74 69 (mbox-receive-ti
5b00: 6d 65 20 20 20 20 28 63 75 72 72 65 6e 74 2d 6d me (current-m
5b10: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 09 illiseconds)))..
5b20: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 (hash-table-de
5b30: 6c 65 74 65 21 20 6d 62 6f 78 65 73 20 71 72 79 lete! mboxes qry
5b40: 6b 65 79 29 0a 09 20 20 28 69 66 20 28 65 71 3f key).. (if (eq?
5b50: 20 72 65 73 20 27 4d 42 4f 58 5f 54 49 4d 45 4f res 'MBOX_TIMEO
5b60: 55 54 29 0a 09 20 20 20 20 20 20 23 66 0a 09 20 UT).. #f..
5b70: 20 20 20 20 20 72 65 73 29 29 0a 09 23 66 29 29 res))..#f))
5b80: 29 20 3b 3b 20 23 66 20 6d 65 61 6e 73 20 66 61 ) ;; #f means fa
5b90: 69 6c 65 64 20 74 6f 20 63 6f 6d 6d 75 6e 69 63 iled to communic
5ba0: 61 74 65 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 ate..;; .(define
5bb0: 20 28 75 6c 65 78 2d 68 61 6e 64 6c 65 72 20 75 (ulex-handler u
5bc0: 64 61 74 61 20 63 6f 6e 74 72 6f 6c 64 61 74 20 data controldat
5bd0: 64 61 74 61 29 0a 20 20 28 70 72 69 6e 74 20 22 data). (print "
5be0: 63 6f 6e 74 72 6f 6c 64 61 74 3a 20 22 20 63 6f controldat: " co
5bf0: 6e 74 72 6f 6c 64 61 74 20 22 20 64 61 74 61 3a ntroldat " data:
5c00: 20 22 20 64 61 74 61 29 0a 20 20 28 6d 61 74 63 " data). (matc
5c10: 68 20 63 6f 6e 74 72 6f 6c 64 61 74 20 3b 3b 20 h controldat ;;
5c20: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 63 (string-split c
5c30: 6f 6e 74 72 6f 6c 64 61 74 29 0a 20 20 20 20 28 ontroldat). (
5c40: 28 68 61 6e 64 6c 65 72 6b 65 79 20 68 6f 73 74 (handlerkey host
5c50: 2d 70 6f 72 74 20 70 69 64 20 71 72 79 6b 65 79 -port pid qrykey
5c60: 20 70 61 72 61 6d 73 20 2e 2e 2e 29 0a 20 20 20 params ...).
5c70: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 68 61 6e ;; (print "han
5c80: 64 6c 65 72 6b 65 79 3a 20 22 20 68 61 6e 64 6c dlerkey: " handl
5c90: 65 72 6b 65 79 20 22 20 68 6f 73 74 2d 70 6f 72 erkey " host-por
5ca0: 74 3a 20 22 20 68 6f 73 74 2d 70 6f 72 74 20 22 t: " host-port "
5cb0: 20 70 69 64 3a 20 22 20 70 69 64 20 22 20 71 72 pid: " pid " qr
5cc0: 79 6b 65 79 3a 20 22 20 71 72 79 6b 65 79 20 22 ykey: " qrykey "
5cd0: 20 70 61 72 61 6d 73 3a 20 22 20 70 61 72 61 6d params: " param
5ce0: 73 29 0a 20 20 20 20 20 28 63 61 73 65 20 68 61 s). (case ha
5cf0: 6e 64 6c 65 72 6b 65 79 20 3b 3b 20 28 73 74 72 ndlerkey ;; (str
5d00: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 68 61 6e 64 ing->symbol hand
5d10: 6c 65 72 6b 65 79 29 0a 20 20 20 20 20 20 20 28 lerkey). (
5d20: 28 61 63 6b 29 28 70 72 69 6e 74 20 22 47 6f 74 (ack)(print "Got
5d30: 20 61 63 6b 21 22 29 29 0a 20 20 20 20 20 20 20 ack!")).
5d40: 28 28 70 69 6e 67 29 20 3b 3b 20 73 70 65 63 69 ((ping) ;; speci
5d50: 61 6c 20 63 61 73 65 20 2d 20 72 65 74 75 72 6e al case - return
5d60: 20 72 65 73 75 6c 74 20 69 6d 6d 65 64 69 61 74 result immediat
5d70: 65 6c 79 20 6f 6e 20 74 68 65 20 73 61 6d 65 20 ely on the same
5d80: 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 28 6c 65 74 connection..(let
5d90: 2a 20 28 28 70 72 6f 63 20 20 28 68 61 73 68 2d * ((proc (hash-
5da0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5db0: 74 20 28 75 64 61 74 2d 68 61 6e 64 6c 65 72 73 t (udat-handlers
5dc0: 20 75 64 61 74 61 29 20 27 70 69 6e 67 20 23 66 udata) 'ping #f
5dd0: 29 29 0a 09 20 20 20 20 20 20 20 28 76 61 6c 20 )).. (val
5de0: 20 20 28 69 66 20 70 72 6f 63 20 28 70 72 6f 63 (if proc (proc
5df0: 29 20 22 67 6f 74 70 69 6e 67 22 29 29 0a 09 20 ) "gotping"))..
5e00: 20 20 20 20 20 20 28 70 65 65 72 20 20 28 6d 61 (peer (ma
5e10: 6b 65 2d 70 65 65 72 20 61 64 64 72 2d 70 6f 72 ke-peer addr-por
5e20: 74 3a 20 68 6f 73 74 2d 70 6f 72 74 20 70 69 64 t: host-port pid
5e30: 3a 20 70 69 64 29 29 0a 09 20 20 20 20 20 20 20 : pid))..
5e40: 28 64 62 73 68 61 73 68 20 28 75 64 61 74 2d 64 (dbshash (udat-d
5e50: 62 6f 77 6e 65 72 73 20 75 64 61 74 61 29 29 29 bowners udata)))
5e60: 0a 09 20 20 28 70 65 65 72 2d 64 62 73 2d 73 65 .. (peer-dbs-se
5e70: 74 21 20 70 65 65 72 20 70 61 72 61 6d 73 29 20 t! peer params)
5e80: 3b 3b 20 70 61 72 61 6d 73 20 66 6f 72 20 70 69 ;; params for pi
5e90: 6e 67 20 69 73 20 6c 69 73 74 20 6f 66 20 64 62 ng is list of db
5ea0: 73 20 6f 77 6e 65 64 20 62 79 20 70 69 6e 67 65 s owned by pinge
5eb0: 72 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 20 28 r.. (for-each (
5ec0: 6c 61 6d 62 64 61 20 28 64 62 66 69 6c 65 29 0a lambda (dbfile).
5ed0: 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 .. (hash-ta
5ee0: 62 6c 65 2d 73 65 74 21 20 64 62 73 68 61 73 68 ble-set! dbshash
5ef0: 20 64 62 66 69 6c 65 20 68 6f 73 74 2d 70 6f 72 dbfile host-por
5f00: 74 29 29 20 3b 3b 20 57 52 4f 4e 47 3f 0a 09 09 t)) ;; WRONG?...
5f10: 20 20 20 20 70 61 72 61 6d 73 29 20 3b 3b 20 72 params) ;; r
5f20: 65 67 69 73 74 65 72 20 65 61 63 68 20 64 62 20 egister each db
5f30: 69 6e 20 74 68 65 20 64 62 73 68 61 73 68 0a 09 in the dbshash..
5f40: 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 (if (not (hash
5f50: 2d 74 61 62 6c 65 2d 65 78 69 73 74 73 3f 20 28 -table-exists? (
5f60: 75 64 61 74 2d 70 65 65 72 73 20 75 64 61 74 61 udat-peers udata
5f70: 29 20 68 6f 73 74 2d 70 6f 72 74 29 29 0a 09 20 ) host-port))..
5f80: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
5f90: 2d 73 65 74 21 20 28 75 64 61 74 2d 70 65 65 72 -set! (udat-peer
5fa0: 73 20 75 64 61 74 61 29 20 68 6f 73 74 2d 70 6f s udata) host-po
5fb0: 72 74 20 70 65 65 72 29 29 20 3b 3b 20 73 61 76 rt peer)) ;; sav
5fc0: 65 20 74 68 65 20 64 65 74 61 69 6c 73 20 6f 66 e the details of
5fd0: 20 74 68 69 73 20 63 61 6c 6c 65 72 20 69 6e 20 this caller in
5fe0: 70 65 65 72 73 0a 09 20 20 71 72 79 6b 65 79 29 peers.. qrykey)
5ff0: 29 20 3b 3b 20 45 6e 64 20 6f 66 20 70 69 6e 67 ) ;; End of ping
6000: 0a 20 20 20 20 20 20 20 28 28 67 6f 6f 64 62 79 . ((goodby
6010: 65 29 0a 09 3b 3b 20 72 65 6d 6f 76 65 20 61 6c e)..;; remove al
6020: 6c 20 74 72 61 63 65 73 20 6f 66 20 74 68 65 20 l traces of the
6030: 63 61 6c 6c 65 72 20 69 6e 20 64 62 20 6f 77 6e caller in db own
6040: 65 72 73 68 69 70 20 65 74 63 2e 0a 09 28 6c 65 ership etc...(le
6050: 74 2a 20 28 28 70 65 65 72 20 20 28 68 61 73 68 t* ((peer (hash
6060: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
6070: 6c 74 20 28 75 64 61 74 2d 70 65 65 72 73 20 75 lt (udat-peers u
6080: 64 61 74 61 29 20 68 6f 73 74 2d 70 6f 72 74 20 data) host-port
6090: 23 66 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 #f)).. (db
60a0: 73 20 20 20 28 69 66 20 70 65 65 72 20 28 70 65 s (if peer (pe
60b0: 65 72 2d 64 62 73 20 70 65 65 72 29 20 27 28 29 er-dbs peer) '()
60c0: 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 73 68 )).. (dbsh
60d0: 61 73 68 20 28 75 64 61 74 2d 64 62 6f 77 6e 65 ash (udat-dbowne
60e0: 72 73 20 75 64 61 74 61 29 29 29 0a 09 20 20 28 rs udata))).. (
60f0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
6100: 20 28 64 62 66 69 6c 65 29 28 68 61 73 68 2d 74 (dbfile)(hash-t
6110: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 64 62 73 able-delete! dbs
6120: 68 61 73 68 20 64 62 66 69 6c 65 29 29 20 64 62 hash dbfile)) db
6130: 73 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c s).. (hash-tabl
6140: 65 2d 64 65 6c 65 74 65 21 20 28 75 64 61 74 2d e-delete! (udat-
6150: 70 65 65 72 73 20 75 64 61 74 61 29 20 68 6f 73 peers udata) hos
6160: 74 2d 70 6f 72 74 29 0a 09 20 20 71 72 79 6b 65 t-port).. qryke
6170: 79 29 29 0a 20 20 20 20 20 20 20 28 28 64 72 6f y)). ((dro
6180: 70 63 61 70 74 61 69 6e 29 0a 09 3b 3b 20 72 65 pcaptain)..;; re
6190: 6d 6f 76 65 20 61 6c 6c 20 74 72 61 63 65 73 20 move all traces
61a0: 6f 66 20 74 68 65 20 63 61 70 74 61 69 6e 0a 09 of the captain..
61b0: 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 61 64 (udat-captain-ad
61c0: 64 72 65 73 73 2d 73 65 74 21 20 75 64 61 74 61 dress-set! udata
61d0: 20 23 66 29 0a 09 28 75 64 61 74 2d 63 61 70 74 #f)..(udat-capt
61e0: 61 69 6e 2d 68 6f 73 74 2d 73 65 74 21 20 20 20 ain-host-set!
61f0: 20 75 64 61 74 61 20 23 66 29 0a 09 28 75 64 61 udata #f)..(uda
6200: 74 2d 63 61 70 74 61 69 6e 2d 70 6f 72 74 2d 73 t-captain-port-s
6210: 65 74 21 20 20 20 20 75 64 61 74 61 20 23 66 29 et! udata #f)
6220: 0a 09 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d ..(udat-captain-
6230: 70 69 64 2d 73 65 74 21 20 20 20 20 20 75 64 61 pid-set! uda
6240: 74 61 20 23 66 29 0a 09 71 72 79 6b 65 79 29 0a ta #f)..qrykey).
6250: 20 20 20 20 20 20 20 28 28 72 75 63 61 70 74 61 ((rucapta
6260: 69 6e 29 20 3b 3b 20 72 65 6d 6f 74 65 20 69 73 in) ;; remote is
6270: 20 61 73 6b 69 6e 67 20 69 66 20 49 27 6d 20 74 asking if I'm t
6280: 68 65 20 63 61 70 74 61 69 6e 0a 09 28 69 66 20 he captain..(if
6290: 28 75 64 61 74 2d 6d 79 2d 63 70 6b 74 2d 6b 65 (udat-my-cpkt-ke
62a0: 79 20 75 64 61 74 61 29 20 22 79 65 73 22 20 22 y udata) "yes" "
62b0: 6e 6f 22 29 29 0a 20 20 20 20 20 20 20 28 28 64 no")). ((d
62c0: 62 2d 6f 77 6e 65 72 29 20 3b 3b 20 67 69 76 65 b-owner) ;; give
62d0: 6e 20 61 20 64 62 20 6e 61 6d 65 20 77 68 6f 20 n a db name who
62e0: 64 6f 20 49 20 73 65 6e 64 20 6d 79 20 71 75 65 do I send my que
62f0: 72 69 65 73 20 74 6f 0a 09 3b 3b 20 6c 6f 6f 6b ries to..;; look
6300: 20 75 70 20 74 68 65 20 66 69 6c 65 20 69 6e 20 up the file in
6310: 68 61 6e 64 6c 65 72 73 2c 20 69 66 20 68 61 76 handlers, if hav
6320: 65 20 61 6e 20 65 6e 74 72 79 20 70 69 6e 67 20 e an entry ping
6330: 74 68 65 6d 20 74 6f 20 62 65 20 73 75 72 65 0a them to be sure.
6340: 09 3b 3b 20 74 68 65 79 20 61 72 65 20 73 74 69 .;; they are sti
6350: 6c 6c 20 61 6c 69 76 65 20 61 6e 64 20 74 68 65 ll alive and the
6360: 6e 20 72 65 74 75 72 6e 20 74 68 61 74 20 68 6f n return that ho
6370: 73 74 3a 70 6f 72 74 2e 0a 09 3b 3b 20 69 66 20 st:port...;; if
6380: 6e 6f 20 68 61 6e 64 6c 65 72 20 66 6f 75 6e 64 no handler found
6390: 20 6f 72 20 69 66 20 74 68 65 20 70 69 6e 67 20 or if the ping
63a0: 66 61 69 6c 73 20 70 69 63 6b 20 66 72 6f 6d 20 fails pick from
63b0: 70 65 65 72 73 20 74 68 65 20 6f 6c 64 65 73 74 peers the oldest
63c0: 20 74 68 61 74 0a 09 3b 3b 20 69 73 20 6d 61 6e that..;; is man
63d0: 61 67 69 6e 67 20 74 68 65 20 66 65 77 65 73 74 aging the fewest
63e0: 20 64 62 73 0a 09 28 6d 61 74 63 68 20 70 61 72 dbs..(match par
63f0: 61 6d 73 0a 09 20 20 28 28 64 62 66 69 6c 65 20 ams.. ((dbfile
6400: 64 62 74 79 70 65 29 0a 09 20 20 20 28 6c 65 74 dbtype).. (let
6410: 2a 20 28 28 6f 77 6e 65 72 2d 68 6f 73 74 2d 70 * ((owner-host-p
6420: 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ort (hash-table-
6430: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 75 64 61 ref/default (uda
6440: 74 2d 64 62 6f 77 6e 65 72 73 20 75 64 61 74 61 t-dbowners udata
6450: 29 20 64 62 66 69 6c 65 20 23 66 29 29 29 0a 09 ) dbfile #f)))..
6460: 20 20 20 20 20 28 69 66 20 6f 77 6e 65 72 2d 68 (if owner-h
6470: 6f 73 74 2d 70 6f 72 74 0a 09 09 20 28 63 6f 6e ost-port... (con
6480: 63 20 71 72 79 6b 65 79 20 22 20 22 20 6f 77 6e c qrykey " " own
6490: 65 72 2d 68 6f 73 74 2d 70 6f 72 74 29 0a 09 09 er-host-port)...
64a0: 20 28 6c 65 74 2a 20 28 28 70 64 61 74 20 28 6f (let* ((pdat (o
64b0: 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 r (hash-table-re
64c0: 66 2f 64 65 66 61 75 6c 74 20 28 75 64 61 74 2d f/default (udat-
64d0: 70 65 65 72 73 20 75 64 61 74 61 29 20 68 6f 73 peers udata) hos
64e0: 74 2d 70 6f 72 74 20 23 66 29 20 3b 3b 20 6e 6f t-port #f) ;; no
64f0: 20 6f 77 6e 65 72 20 2d 20 63 61 6c 6c 65 72 20 owner - caller
6500: 67 65 74 73 20 74 6f 20 6f 77 6e 20 69 74 21 0a gets to own it!.
6510: 09 09 09 09 20 20 28 6d 61 6b 65 2d 70 65 65 72 .... (make-peer
6520: 20 61 64 64 72 2d 70 6f 72 74 3a 20 68 6f 73 74 addr-port: host
6530: 2d 70 6f 72 74 20 70 69 64 3a 20 70 69 64 20 64 -port pid: pid d
6540: 62 73 3a 20 60 28 2c 64 62 66 69 6c 65 29 29 29 bs: `(,dbfile)))
6550: 29 29 0a 09 09 20 20 20 28 68 61 73 68 2d 74 61 ))... (hash-ta
6560: 62 6c 65 2d 73 65 74 21 20 28 75 64 61 74 2d 70 ble-set! (udat-p
6570: 65 65 72 73 20 75 64 61 74 61 29 20 68 6f 73 74 eers udata) host
6580: 2d 70 6f 72 74 20 70 64 61 74 29 0a 09 09 20 20 -port pdat)...
6590: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
65a0: 21 20 28 75 64 61 74 2d 64 62 6f 77 6e 65 72 73 ! (udat-dbowners
65b0: 20 75 64 61 74 61 29 20 64 62 66 69 6c 65 20 68 udata) dbfile h
65c0: 6f 73 74 2d 70 6f 72 74 29 0a 09 09 20 20 20 28 ost-port)... (
65d0: 63 6f 6e 63 20 71 72 79 6b 65 79 20 22 20 22 20 conc qrykey " "
65e0: 68 6f 73 74 2d 70 6f 72 74 29 29 29 29 29 0a 09 host-port)))))..
65f0: 20 20 28 65 6c 73 65 20 28 63 6f 6e 63 20 71 72 (else (conc qr
6600: 79 6b 65 79 20 22 20 42 41 44 44 41 54 41 22 29 ykey " BADDATA")
6610: 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 66 6f ))). ;; fo
6620: 72 20 77 6f 72 6b 20 69 74 65 6d 73 3a 0a 20 20 r work items:.
6630: 20 20 20 20 20 3b 3b 20 20 20 20 68 61 6e 64 6c ;; handl
6640: 65 72 20 69 73 20 6f 6e 65 20 6f 66 3b 20 69 6d er is one of; im
6650: 6d 65 64 69 61 74 65 2c 20 72 65 61 64 2d 6f 6e mediate, read-on
6660: 6c 79 2c 20 72 65 61 64 2d 77 72 69 74 65 2c 20 ly, read-write,
6670: 68 69 67 68 2d 70 72 69 6f 72 69 74 79 0a 20 20 high-priority.
6680: 20 20 20 20 20 28 28 69 6d 6d 65 64 69 61 74 65 ((immediate
6690: 20 72 65 61 64 2d 6f 6e 6c 79 20 6e 6f 72 6d 61 read-only norma
66a0: 6c 20 6c 6f 77 2d 70 72 69 6f 72 69 74 79 29 20 l low-priority)
66b0: 3b 3b 20 64 6f 20 74 68 69 73 20 77 6f 72 6b 20 ;; do this work
66c0: 69 6d 6d 65 64 69 61 74 65 6c 79 0a 09 3b 3b 20 immediately..;;
66d0: 68 6f 73 74 2d 70 6f 72 74 20 28 63 61 6c 6c 65 host-port (calle
66e0: 72 29 2c 20 70 69 64 20 28 63 61 6c 6c 65 72 29 r), pid (caller)
66f0: 2c 20 71 72 79 6b 65 79 20 28 63 6f 6f 6b 69 65 , qrykey (cookie
6700: 29 2c 20 70 61 72 61 6d 73 20 3c 3d 20 61 6c 6c ), params <= all
6710: 20 66 72 6f 6d 20 66 69 72 73 74 20 6c 69 6e 65 from first line
6720: 0a 09 3b 3b 20 64 61 74 61 20 3d 3e 20 61 20 73 ..;; data => a s
6730: 69 6e 67 6c 65 20 6c 69 6e 65 20 65 6e 63 6f 64 ingle line encod
6740: 65 64 20 68 6f 77 65 76 65 72 20 79 6f 75 20 77 ed however you w
6750: 61 6e 74 2c 20 6f 72 20 73 68 6f 75 6c 64 20 49 ant, or should I
6760: 20 62 75 69 6c 64 20 6a 73 6f 6e 20 69 6e 74 6f build json into
6770: 20 69 74 3f 0a 09 28 70 72 69 6e 74 20 22 68 61 it?..(print "ha
6780: 6e 64 6c 65 72 6b 65 79 3d 22 20 68 61 6e 64 6c ndlerkey=" handl
6790: 65 72 6b 65 79 29 0a 09 28 6c 65 74 2a 20 28 28 erkey)..(let* ((
67a0: 70 64 61 74 20 28 67 65 74 2d 70 65 65 72 2d 64 pdat (get-peer-d
67b0: 61 74 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f at udata host-po
67c0: 72 74 29 29 29 0a 09 20 20 28 6d 61 74 63 68 20 rt))).. (match
67d0: 70 61 72 61 6d 73 20 3b 3b 20 64 62 66 69 6c 65 params ;; dbfile
67e0: 20 70 72 6f 63 6b 65 79 20 70 72 6f 63 70 61 72 prockey procpar
67f0: 61 6d 0a 09 20 20 20 20 28 28 64 62 66 69 6c 65 am.. ((dbfile
6800: 20 70 72 6f 63 6b 65 79 20 70 72 6f 63 70 61 72 prockey procpar
6810: 61 6d 29 0a 09 20 20 20 20 20 28 63 61 73 65 20 am).. (case
6820: 68 61 6e 64 6c 65 72 6b 65 79 0a 09 20 20 20 20 handlerkey..
6830: 20 20 20 28 28 69 6d 6d 65 64 69 61 74 65 20 72 ((immediate r
6840: 65 61 64 2d 6f 6e 6c 79 29 0a 09 09 28 70 72 6f ead-only)...(pro
6850: 63 65 73 73 2d 72 65 71 75 65 73 74 20 75 64 61 cess-request uda
6860: 74 61 20 70 64 61 74 20 64 62 66 69 6c 65 20 71 ta pdat dbfile q
6870: 72 79 6b 65 79 20 70 72 6f 63 6b 65 79 20 70 72 rykey prockey pr
6880: 6f 63 70 61 72 61 6d 20 64 61 74 61 29 29 0a 09 ocparam data))..
6890: 20 20 20 20 20 20 20 28 28 6e 6f 72 6d 61 6c 20 ((normal
68a0: 6c 6f 77 2d 70 72 69 6f 72 69 74 79 29 20 3b 3b low-priority) ;;
68b0: 20 73 70 6c 69 74 20 6f 66 66 20 6c 61 74 65 72 split off later
68c0: 20 61 6e 64 20 61 64 64 20 6c 6f 67 69 63 20 74 and add logic t
68d0: 6f 20 73 75 70 70 6f 72 74 20 6c 6f 77 20 70 72 o support low pr
68e0: 69 6f 72 69 74 79 0a 09 09 28 61 64 64 2d 74 6f iority...(add-to
68f0: 2d 77 6f 72 6b 2d 71 75 65 75 65 20 75 64 61 74 -work-queue udat
6900: 61 20 70 64 61 74 20 64 62 66 69 6c 65 20 71 72 a pdat dbfile qr
6910: 79 6b 65 79 20 70 72 6f 63 6b 65 79 20 70 72 6f ykey prockey pro
6920: 63 70 61 72 61 6d 20 64 61 74 61 29 29 0a 09 20 cparam data))..
6930: 20 20 20 20 20 20 28 65 6c 73 65 0a 09 09 23 66 (else...#f
6940: 29 29 29 0a 09 20 20 20 20 28 65 6c 73 65 0a 09 ))).. (else..
6950: 20 20 20 20 20 28 70 72 69 6e 74 20 22 49 4e 46 (print "INF
6960: 4f 3a 20 70 61 72 61 6d 73 3d 22 20 70 61 72 61 O: params=" para
6970: 6d 73 20 22 20 68 61 6e 64 6c 65 72 6b 65 79 3d ms " handlerkey=
6980: 22 20 68 61 6e 64 6c 65 72 6b 65 79 20 22 20 63 " handlerkey " c
6990: 6f 6e 74 72 6f 6c 64 61 74 3d 22 20 63 6f 6e 74 ontroldat=" cont
69a0: 72 6f 6c 64 61 74 29 0a 09 20 20 20 20 20 23 66 roldat).. #f
69b0: 29 29 29 29 0a 20 20 20 20 20 20 20 28 65 6c 73 )))). (els
69c0: 65 0a 09 3b 3b 20 28 61 64 64 2d 74 6f 2d 77 6f e..;; (add-to-wo
69d0: 72 6b 2d 71 75 65 75 65 20 75 64 61 74 61 20 28 rk-queue udata (
69e0: 67 65 74 2d 70 65 65 72 2d 64 61 74 20 75 64 61 get-peer-dat uda
69f0: 74 61 20 68 6f 73 74 2d 70 6f 72 74 29 20 68 61 ta host-port) ha
6a00: 6e 64 6c 65 72 6b 65 79 20 71 72 79 6b 65 79 20 ndlerkey qrykey
6a10: 64 61 74 61 29 0a 09 23 66 29 29 29 0a 20 20 20 data)..#f))).
6a20: 20 28 65 6c 73 65 0a 20 20 20 20 20 28 70 72 69 (else. (pri
6a30: 6e 74 20 22 42 41 44 20 44 41 54 41 3f 20 63 6f nt "BAD DATA? co
6a40: 6e 74 72 6f 6c 64 61 74 3d 22 20 63 6f 6e 74 72 ntroldat=" contr
6a50: 6f 6c 64 61 74 20 22 20 64 61 74 61 3d 22 20 64 oldat " data=" d
6a60: 61 74 61 29 0a 20 20 20 20 20 23 66 29 29 29 3b ata). #f)));
6a70: 3b 20 68 61 6e 64 6c 65 73 20 74 68 65 20 69 6e ; handles the in
6a80: 63 6f 6d 69 6e 67 20 6d 65 73 73 61 67 65 73 20 coming messages
6a90: 61 6e 64 20 64 69 73 70 61 74 63 68 65 73 20 74 and dispatches t
6aa0: 6f 20 71 75 65 75 65 73 0a 0a 3b 3b 0a 28 64 65 o queues..;;.(de
6ab0: 66 69 6e 65 20 28 75 6c 65 78 2d 68 61 6e 64 6c fine (ulex-handl
6ac0: 65 72 2d 6c 6f 6f 70 20 75 64 61 74 61 29 0a 20 er-loop udata).
6ad0: 20 28 6c 65 74 2a 20 28 28 73 65 72 76 2d 6c 69 (let* ((serv-li
6ae0: 73 74 65 6e 65 72 20 28 75 64 61 74 2d 73 65 72 stener (udat-ser
6af0: 76 2d 6c 69 73 74 65 6e 65 72 20 75 64 61 74 61 v-listener udata
6b00: 29 29 29 0a 20 20 20 20 3b 3b 20 64 61 74 61 20 ))). ;; data
6b10: 63 6f 6d 65 73 20 61 73 20 74 77 6f 20 6c 69 6e comes as two lin
6b20: 65 73 0a 20 20 20 20 3b 3b 20 20 20 68 61 6e 64 es. ;; hand
6b30: 6c 65 72 6b 65 79 20 72 65 73 70 2d 61 64 64 72 lerkey resp-addr
6b40: 3a 72 65 73 70 2d 70 6f 72 74 20 68 6f 73 74 6e :resp-port hostn
6b50: 61 6d 65 20 70 69 64 20 71 72 79 6b 65 79 20 5b ame pid qrykey [
6b60: 64 62 70 61 74 68 2f 64 62 66 69 6c 65 2e 64 62 dbpath/dbfile.db
6b70: 5d 0a 20 20 20 20 3b 3b 20 20 20 64 61 74 61 0a ]. ;; data.
6b80: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
6b90: 73 74 61 74 65 20 27 73 74 61 72 74 29 29 0a 20 state 'start)).
6ba0: 20 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 (let-values
6bb0: 20 28 28 28 69 6e 70 20 6f 75 70 29 28 74 63 70 (((inp oup)(tcp
6bc0: 2d 61 63 63 65 70 74 20 73 65 72 76 2d 6c 69 73 -accept serv-lis
6bd0: 74 65 6e 65 72 29 29 29 0a 09 28 6c 65 74 2a 20 tener)))..(let*
6be0: 28 28 63 6f 6e 74 72 6f 6c 64 61 74 20 28 72 65 ((controldat (re
6bf0: 61 64 20 69 6e 70 29 29 0a 09 20 20 20 20 20 20 ad inp))..
6c00: 20 28 64 61 74 61 20 20 20 20 20 20 20 28 72 65 (data (re
6c10: 61 64 20 69 6e 70 29 29 0a 09 20 20 20 20 20 20 ad inp))..
6c20: 20 28 72 65 73 70 20 20 20 20 20 20 20 28 75 6c (resp (ul
6c30: 65 78 2d 68 61 6e 64 6c 65 72 20 75 64 61 74 61 ex-handler udata
6c40: 20 63 6f 6e 74 72 6f 6c 64 61 74 20 64 61 74 61 controldat data
6c50: 29 29 29 0a 09 20 20 28 69 66 20 72 65 73 70 20 ))).. (if resp
6c60: 28 77 72 69 74 65 20 72 65 73 70 20 6f 75 70 29 (write resp oup)
6c70: 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 ).. (close-inpu
6c80: 74 2d 70 6f 72 74 20 69 6e 70 29 0a 09 20 20 28 t-port inp).. (
6c90: 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
6ca0: 74 20 6f 75 70 29 29 0a 09 28 6c 6f 6f 70 20 73 t oup))..(loop s
6cb0: 74 61 74 65 29 29 29 29 29 0a 0a 3b 3b 20 61 64 tate)))))..;; ad
6cc0: 64 20 61 20 70 72 6f 63 20 74 6f 20 74 68 65 20 d a proc to the
6cd0: 68 61 6e 64 6c 65 72 20 6c 69 73 74 2c 20 74 68 handler list, th
6ce0: 65 73 65 20 61 72 65 20 64 6f 6e 65 20 73 79 6d ese are done sym
6cf0: 65 74 72 69 63 61 6c 6c 79 20 28 69 2e 65 2e 20 etrically (i.e.
6d00: 69 6e 20 61 6c 6c 20 69 6e 73 74 61 6e 63 65 73 in all instances
6d10: 29 0a 3b 3b 20 73 6f 20 74 68 61 74 20 74 68 65 ).;; so that the
6d20: 20 70 72 6f 63 20 63 61 6e 20 62 65 20 64 65 72 proc can be der
6d30: 65 66 65 72 65 6e 63 65 64 20 72 65 6d 6f 74 65 eferenced remote
6d40: 6c 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 ly.;;.(define (r
6d50: 65 67 69 73 74 65 72 2d 68 61 6e 64 6c 65 72 20 egister-handler
6d60: 75 64 61 74 61 20 6b 65 79 20 70 72 6f 63 29 0a udata key proc).
6d70: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
6d80: 74 21 20 28 75 64 61 74 2d 68 61 6e 64 6c 65 72 t! (udat-handler
6d90: 73 20 75 64 61 74 61 29 20 6b 65 79 20 70 72 6f s udata) key pro
6da0: 63 29 29 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d c))...;;========
6db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
6df0: 3b 20 77 6f 72 6b 20 71 75 65 75 65 73 0a 3b 3b ; work queues.;;
6e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e40: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
6e50: 28 61 64 64 2d 74 6f 2d 77 6f 72 6b 2d 71 75 65 (add-to-work-que
6e60: 75 65 20 75 64 61 74 61 20 70 65 65 72 2d 64 61 ue udata peer-da
6e70: 74 20 68 61 6e 64 6c 65 72 6b 65 79 20 71 72 79 t handlerkey qry
6e80: 6b 65 79 20 64 61 74 61 29 0a 20 20 28 6c 65 74 key data). (let
6e90: 20 28 28 77 64 61 74 20 28 6d 61 6b 65 2d 77 6f ((wdat (make-wo
6ea0: 72 6b 20 70 65 65 72 2d 64 61 74 3a 20 70 65 65 rk peer-dat: pee
6eb0: 72 2d 64 61 74 20 68 61 6e 64 6c 65 72 6b 65 79 r-dat handlerkey
6ec0: 3a 20 68 61 6e 64 6c 65 72 6b 65 79 20 71 72 79 : handlerkey qry
6ed0: 6b 65 79 3a 20 71 72 79 6b 65 79 20 64 61 74 61 key: qrykey data
6ee0: 3a 20 64 61 74 61 29 29 29 0a 20 20 20 20 28 69 : data))). (i
6ef0: 66 20 28 75 64 61 74 2d 62 75 73 79 20 75 64 61 f (udat-busy uda
6f00: 74 61 29 0a 09 28 71 75 65 75 65 2d 61 64 64 21 ta)..(queue-add!
6f10: 20 28 75 64 61 74 2d 77 6f 72 6b 2d 71 75 65 75 (udat-work-queu
6f20: 65 20 75 64 61 74 61 29 20 77 64 61 74 29 0a 09 e udata) wdat)..
6f30: 28 70 72 6f 63 65 73 73 2d 77 6f 72 6b 20 75 64 (process-work ud
6f40: 61 74 61 20 77 64 61 74 29 29 20 3b 3b 20 70 61 ata wdat)) ;; pa
6f50: 73 73 69 6e 67 20 69 6e 20 77 64 61 74 20 74 65 ssing in wdat te
6f60: 6c 6c 73 20 70 72 6f 63 65 73 73 2d 77 6f 72 6b lls process-work
6f70: 20 74 6f 20 66 69 72 73 74 20 70 72 6f 63 65 73 to first proces
6f80: 73 20 74 68 65 20 70 61 73 73 65 64 20 69 6e 20 s the passed in
6f90: 77 64 61 74 0a 20 20 20 20 29 29 0a 0a 28 64 65 wdat. ))..(de
6fa0: 66 69 6e 65 20 28 64 6f 2d 77 6f 72 6b 20 75 64 fine (do-work ud
6fb0: 61 74 61 20 77 64 61 74 29 0a 20 20 23 66 29 0a ata wdat). #f).
6fc0: 0a 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 .(define (proces
6fd0: 73 2d 77 6f 72 6b 20 75 64 61 74 61 20 23 21 6f s-work udata #!o
6fe0: 70 74 69 6f 6e 61 6c 20 77 64 61 74 29 0a 20 20 ptional wdat).
6ff0: 28 69 66 20 77 64 61 74 20 28 64 6f 2d 77 6f 72 (if wdat (do-wor
7000: 6b 20 75 64 61 74 61 20 77 64 61 74 29 29 20 3b k udata wdat)) ;
7010: 3b 20 70 72 6f 63 65 73 73 20 77 64 61 74 0a 20 ; process wdat.
7020: 20 28 6c 65 74 20 28 28 77 71 75 65 75 65 20 28 (let ((wqueue (
7030: 75 64 61 74 2d 77 6f 72 6b 2d 71 75 65 75 65 20 udat-work-queue
7040: 75 64 61 74 61 29 29 29 0a 20 20 20 20 28 69 66 udata))). (if
7050: 20 28 6e 6f 74 20 28 71 75 65 75 65 2d 65 6d 70 (not (queue-emp
7060: 74 79 3f 20 77 71 75 65 75 65 29 29 0a 09 28 6c ty? wqueue))..(l
7070: 65 74 20 6c 6f 6f 70 20 28 28 77 64 20 28 71 75 et loop ((wd (qu
7080: 65 75 65 2d 72 65 6d 6f 76 65 21 20 77 71 75 65 eue-remove! wque
7090: 75 65 29 29 29 0a 09 20 20 28 64 6f 2d 77 6f 72 ue))).. (do-wor
70a0: 6b 20 75 64 61 74 61 20 77 64 29 0a 09 20 20 28 k udata wd).. (
70b0: 69 66 20 28 6e 6f 74 20 28 71 75 65 75 65 2d 65 if (not (queue-e
70c0: 6d 70 74 79 3f 20 77 71 75 65 75 65 29 29 0a 09 mpty? wqueue))..
70d0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 71 75 65 (loop (que
70e0: 75 65 2d 72 65 6d 6f 76 65 21 20 77 71 75 65 75 ue-remove! wqueu
70f0: 65 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d e)))))))..;;====
7100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7140: 3d 3d 0a 3b 3b 20 47 65 6e 65 72 69 63 20 64 62 ==.;; Generic db
7150: 20 68 61 6e 64 6c 69 6e 67 0a 3b 3b 20 20 20 73 handling.;; s
7160: 65 74 75 70 20 61 20 69 6e 6d 65 6d 20 64 62 20 etup a inmem db
7170: 69 6e 73 74 61 6e 63 65 0a 3b 3b 20 20 20 6f 70 instance.;; op
7180: 65 6e 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 74 6f en connection to
7190: 20 6f 6e 2d 64 69 73 6b 20 64 62 0a 3b 3b 20 20 on-disk db.;;
71a0: 20 73 79 6e 63 20 6f 6e 2d 64 69 73 6b 20 64 62 sync on-disk db
71b0: 20 74 6f 20 69 6e 6d 65 6d 0a 3b 3b 20 20 20 67 to inmem.;; g
71c0: 65 74 20 6c 6f 63 6b 20 69 6e 20 6f 6e 2d 64 69 et lock in on-di
71d0: 73 6b 20 64 62 20 66 6f 72 20 64 62 6f 77 6e 65 sk db for dbowne
71e0: 72 20 6f 66 20 74 68 69 73 20 64 62 0a 3b 3b 20 r of this db.;;
71f0: 20 20 70 75 74 20 73 79 6e 63 2d 70 72 6f 63 2c put sync-proc,
7200: 20 69 6e 69 74 2d 70 72 6f 63 2c 20 6f 6e 2d 64 init-proc, on-d
7210: 69 73 6b 20 68 61 6e 64 6c 65 2c 20 69 6e 6d 65 isk handle, inme
7220: 6d 20 68 61 6e 64 6c 65 20 69 6e 20 64 62 63 6f m handle in dbco
7230: 6e 6e 20 73 74 75 63 74 0a 3b 3b 20 20 20 72 65 nn stuct.;; re
7240: 74 75 72 6e 20 74 68 65 20 73 74 75 63 74 0a 3b turn the stuct.;
7250: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7290: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 73 74 72 =======..(defstr
72a0: 75 63 74 20 64 62 63 6f 6e 6e 0a 20 20 28 66 6e uct dbconn. (fn
72b0: 61 6d 65 20 20 23 66 29 0a 20 20 28 69 6e 6d 65 ame #f). (inme
72c0: 6d 20 20 23 66 29 0a 20 20 28 63 6f 6e 6e 20 20 m #f). (conn
72d0: 20 23 66 29 0a 20 20 28 73 79 6e 63 20 20 20 23 #f). (sync #
72e0: 66 29 20 3b 3b 20 73 79 6e 63 20 70 72 6f 63 0a f) ;; sync proc.
72f0: 20 20 28 69 6e 69 74 20 20 20 23 66 29 20 3b 3b (init #f) ;;
7300: 20 69 6e 69 74 20 70 72 6f 63 0a 20 20 28 6c 61 init proc. (la
7310: 73 74 73 79 6e 63 20 28 63 75 72 72 65 6e 74 2d stsync (current-
7320: 73 65 63 6f 6e 64 73 29 29 0a 20 20 29 0a 0a 28 seconds)). )..(
7330: 64 65 66 73 74 72 75 63 74 20 64 62 69 6e 66 6f defstruct dbinfo
7340: 0a 20 20 28 69 6e 69 74 70 72 6f 63 20 23 66 29 . (initproc #f)
7350: 0a 20 20 28 73 79 6e 63 70 72 6f 63 20 23 66 29 . (syncproc #f)
7360: 29 0a 0a 3b 3b 20 6f 70 65 6e 20 69 6e 6d 65 6d )..;; open inmem
7370: 20 61 6e 64 20 64 69 73 6b 20 64 61 74 61 62 61 and disk databa
7380: 73 65 0a 3b 3b 20 20 20 69 6e 69 74 20 77 69 74 se.;; init wit
7390: 68 20 69 6e 69 74 70 72 6f 63 0a 3b 3b 20 20 20 h initproc.;;
73a0: 72 65 74 75 72 6e 20 64 62 20 73 74 72 75 63 74 return db struct
73b0: 0a 3b 3b 0a 3b 3b 20 20 20 61 70 70 6e 61 6d 65 .;;.;; appname
73c0: 3b 20 6d 65 67 61 74 65 73 74 2c 20 75 6c 65 78 ; megatest, ulex
73d0: 20 6f 72 20 73 6f 6d 65 74 68 69 6e 67 20 65 6c or something el
73e0: 73 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 se..;;.(define (
73f0: 73 65 74 75 70 2d 64 62 2d 63 6f 6e 6e 65 63 74 setup-db-connect
7400: 69 6f 6e 20 75 64 61 74 61 20 66 6e 61 6d 65 2d ion udata fname-
7410: 69 6e 20 61 70 70 6e 61 6d 65 20 64 62 74 79 70 in appname dbtyp
7420: 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 73 2d e). (let* ((is-
7430: 75 6c 65 78 20 28 65 71 3f 20 61 70 70 6e 61 6d ulex (eq? appnam
7440: 65 20 27 75 6c 65 78 29 29 0a 09 20 28 64 62 69 e 'ulex)).. (dbi
7450: 6e 66 20 20 20 28 69 66 20 69 73 2d 75 6c 65 78 nf (if is-ulex
7460: 20 3b 3b 20 75 6c 65 78 20 69 73 20 61 20 62 75 ;; ulex is a bu
7470: 69 6c 74 2d 69 6e 20 73 70 65 63 69 61 6c 20 63 ilt-in special c
7480: 61 73 65 0a 09 09 20 20 20 20 20 20 28 6d 61 6b ase... (mak
7490: 65 2d 64 62 69 6e 66 6f 20 69 6e 69 74 70 72 6f e-dbinfo initpro
74a0: 63 3a 20 75 6c 65 78 64 62 2d 69 6e 69 74 20 73 c: ulexdb-init s
74b0: 79 6e 63 70 72 6f 63 3a 20 75 6c 65 78 64 62 2d yncproc: ulexdb-
74c0: 73 79 6e 63 29 0a 09 09 20 20 20 20 20 20 28 68 sync)... (h
74d0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
74e0: 66 61 75 6c 74 20 28 75 64 61 74 2d 64 62 74 79 fault (udat-dbty
74f0: 70 65 73 20 75 64 61 74 61 29 20 64 62 74 79 70 pes udata) dbtyp
7500: 65 20 23 66 29 29 29 0a 09 20 28 69 6e 69 74 70 e #f))).. (initp
7510: 72 6f 63 20 28 64 62 69 6e 66 6f 2d 69 6e 69 74 roc (dbinfo-init
7520: 70 72 6f 63 20 64 62 69 6e 66 29 29 0a 09 20 28 proc dbinf)).. (
7530: 73 79 6e 63 70 72 6f 63 20 28 64 62 69 6e 66 6f syncproc (dbinfo
7540: 2d 73 79 6e 63 70 72 6f 63 20 64 62 69 6e 66 29 -syncproc dbinf)
7550: 29 0a 09 20 28 66 6e 61 6d 65 20 20 20 28 69 66 ).. (fname (if
7560: 20 69 73 2d 75 6c 65 78 0a 09 09 20 20 20 20 20 is-ulex...
7570: 20 28 63 6f 6e 63 20 28 75 64 61 74 2d 75 6c 65 (conc (udat-ule
7580: 78 2d 64 69 72 20 75 64 61 74 61 29 20 22 2f 75 x-dir udata) "/u
7590: 6c 65 78 2e 64 62 22 29 0a 09 09 20 20 20 20 20 lex.db")...
75a0: 20 66 6e 61 6d 65 2d 69 6e 29 29 0a 09 20 28 69 fname-in)).. (i
75b0: 6e 6d 65 6d 2d 64 62 20 28 6f 70 65 6e 2d 61 6e nmem-db (open-an
75c0: 64 2d 69 6e 69 74 64 62 20 75 64 61 74 61 20 23 d-initdb udata #
75d0: 66 20 27 69 6e 6d 65 6d 20 28 64 62 69 6e 66 6f f 'inmem (dbinfo
75e0: 2d 69 6e 69 74 70 72 6f 63 20 64 62 69 6e 66 29 -initproc dbinf)
75f0: 29 29 0a 09 20 28 64 69 73 6b 2d 64 62 20 20 28 )).. (disk-db (
7600: 6f 70 65 6e 2d 61 6e 64 2d 69 6e 69 74 64 62 20 open-and-initdb
7610: 75 64 61 74 61 20 66 6e 61 6d 65 20 27 64 69 73 udata fname 'dis
7620: 6b 20 28 64 62 69 6e 66 6f 2d 69 6e 69 74 70 72 k (dbinfo-initpr
7630: 6f 63 20 64 62 69 6e 66 29 29 29 29 0a 20 20 20 oc dbinf)))).
7640: 20 28 6d 61 6b 65 2d 64 62 63 6f 6e 6e 20 69 6e (make-dbconn in
7650: 6d 65 6d 3a 20 69 6e 6d 65 6d 2d 64 62 20 63 6f mem: inmem-db co
7660: 6e 6e 3a 20 64 69 73 6b 2d 64 62 20 73 79 6e 63 nn: disk-db sync
7670: 3a 20 73 79 6e 63 70 72 6f 63 20 69 6e 69 74 3a : syncproc init:
7680: 20 69 6e 69 74 70 72 6f 63 29 29 29 0a 0a 3b 3b initproc)))..;;
7690: 20 64 65 73 74 3d 27 69 6e 6d 65 6d 20 6f 72 20 dest='inmem or
76a0: 27 64 69 73 6b 0a 3b 3b 0a 28 64 65 66 69 6e 65 'disk.;;.(define
76b0: 20 28 6f 70 65 6e 2d 61 6e 64 2d 69 6e 69 74 64 (open-and-initd
76c0: 62 20 75 64 61 74 61 20 66 69 6c 65 6e 61 6d 65 b udata filename
76d0: 20 64 65 73 74 20 69 6e 69 74 2d 70 72 6f 63 29 dest init-proc)
76e0: 0a 20 20 28 6c 65 74 2a 20 28 28 69 6e 6d 65 6d . (let* ((inmem
76f0: 20 20 20 20 28 65 71 3f 20 64 65 73 74 20 27 69 (eq? dest 'i
7700: 6e 6d 65 6d 29 29 0a 09 20 28 64 62 66 69 6c 65 nmem)).. (dbfile
7710: 20 20 20 28 69 66 20 69 6e 6d 65 6d 0a 09 09 20 (if inmem...
7720: 20 20 20 20 20 20 22 3a 49 4e 4d 45 4d 3a 22 0a ":INMEM:".
7730: 09 09 20 20 20 20 20 20 20 66 69 6c 65 6e 61 6d .. filenam
7740: 65 29 29 0a 09 20 28 64 62 65 78 69 73 74 73 20 e)).. (dbexists
7750: 28 69 66 20 69 6e 6d 65 6d 20 23 74 20 28 66 69 (if inmem #t (fi
7760: 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 66 69 6c le-exists? dbfil
7770: 65 29 29 29 0a 09 20 28 64 62 20 20 20 20 20 20 e))).. (db
7780: 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 (sqlite3:open-d
7790: 61 74 61 62 61 73 65 20 64 62 66 69 6c 65 29 29 atabase dbfile))
77a0: 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 73 ). (sqlite3:s
77b0: 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 et-busy-handler!
77c0: 20 64 62 20 28 73 71 6c 69 74 65 33 3a 6d 61 6b db (sqlite3:mak
77d0: 65 2d 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 e-busy-timeout 1
77e0: 33 36 30 30 30 29 29 0a 20 20 20 20 28 69 66 20 36000)). (if
77f0: 28 6e 6f 74 20 64 62 65 78 69 73 74 73 29 0a 09 (not dbexists)..
7800: 28 69 6e 69 74 2d 70 72 6f 63 20 64 62 29 29 0a (init-proc db)).
7810: 20 20 20 20 64 62 29 29 0a 0a 0a 3b 3b 3d 3d 3d db))...;;===
7820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7860: 3d 3d 3d 0a 3b 3b 20 50 72 65 76 69 6f 75 73 20 ===.;; Previous
7870: 55 6c 65 78 20 64 62 20 73 74 75 66 66 0a 3b 3b Ulex db stuff.;;
7880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78c0: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
78d0: 28 75 6c 65 78 64 62 2d 69 6e 69 74 20 64 62 20 (ulexdb-init db
78e0: 69 6e 6d 65 6d 29 0a 20 20 28 73 71 6c 69 74 65 inmem). (sqlite
78f0: 33 3a 77 69 74 68 2d 74 72 61 6e 73 61 63 74 69 3:with-transacti
7900: 6f 6e 0a 20 20 20 64 62 0a 20 20 20 28 6c 61 6d on. db. (lam
7910: 62 64 61 20 28 29 0a 20 20 20 20 20 28 66 6f 72 bda (). (for
7920: 2d 65 61 63 68 0a 20 20 20 20 20 20 28 6c 61 6d -each. (lam
7930: 62 64 61 20 28 73 74 6d 74 29 0a 09 28 69 66 20 bda (stmt)..(if
7940: 73 74 6d 74 20 28 73 71 6c 69 74 65 33 3a 65 78 stmt (sqlite3:ex
7950: 65 63 75 74 65 20 64 62 20 73 74 6d 74 29 29 29 ecute db stmt)))
7960: 0a 20 20 20 20 20 20 60 28 22 43 52 45 41 54 45 . `("CREATE
7970: 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 TABLE IF NOT EX
7980: 49 53 54 53 20 70 72 6f 63 65 73 73 65 73 20 0a ISTS processes .
7990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79a0: 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
79b0: 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 MARY KEY,.
79c0: 20 20 20 20 20 20 20 20 20 20 20 20 68 6f 73 74 host
79d0: 20 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c TEXT NOT NULL,
79e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
79f0: 20 20 20 69 70 61 64 72 20 54 45 58 54 20 4e 4f ipadr TEXT NO
7a00: 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 T NULL,.
7a10: 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 20 20 port
7a20: 49 4e 54 45 47 45 52 20 4e 4f 54 20 4e 55 4c 4c INTEGER NOT NULL
7a30: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,.
7a40: 20 20 20 20 70 69 64 20 20 20 49 4e 54 45 47 45 pid INTEGE
7a50: 52 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 R NOT NULL,.
7a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 re
7a70: 67 74 69 6d 65 20 49 4e 54 45 47 45 52 20 44 45 gtime INTEGER DE
7a80: 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d 65 28 FAULT (strftime(
7a90: 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c 0a 20 20 '%s','now')),.
7aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ab0: 6c 61 73 74 5f 75 70 64 61 74 65 20 49 4e 54 45 last_update INTE
7ac0: 47 45 52 20 44 45 46 41 55 4c 54 20 28 73 74 72 GER DEFAULT (str
7ad0: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
7ae0: 29 29 29 3b 22 0a 09 28 69 66 20 69 6e 6d 65 6d )));"..(if inmem
7af0: 0a 09 20 20 20 20 22 43 52 45 41 54 45 20 54 52 .. "CREATE TR
7b00: 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 58 IGGER IF NOT EX
7b10: 49 53 54 53 20 75 70 64 61 74 65 5f 70 72 6f 63 ISTS update_proc
7b20: 65 73 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 es_trigger AFTER
7b30: 20 55 50 44 41 54 45 20 4f 4e 20 70 72 6f 63 65 UPDATE ON proce
7b40: 73 73 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 sses.
7b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b60: 20 20 46 4f 52 20 45 41 43 48 20 52 4f 57 0a 20 FOR EACH ROW.
7b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 42 45 BE
7b90: 47 49 4e 20 0a 20 20 20 20 20 20 20 20 20 20 20 GIN .
7ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7bb0: 20 20 20 20 20 20 55 50 44 41 54 45 20 70 72 6f UPDATE pro
7bc0: 63 65 73 73 65 73 20 53 45 54 20 6c 61 73 74 5f cesses SET last_
7bd0: 75 70 64 61 74 65 3d 28 73 74 72 66 74 69 6d 65 update=(strftime
7be0: 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 20 ('%s','now')).
7bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c10: 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 64 WHERE id=old.id
7c20: 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;.
7c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c40: 20 45 4e 44 3b 22 0a 09 20 20 20 20 23 66 29 29 END;".. #f))
7c50: 29 29 29 29 0a 0a 3b 3b 20 6f 70 65 6e 20 64 61 ))))..;; open da
7c60: 74 61 62 61 73 65 73 2c 20 64 6f 20 69 6e 69 74 tabases, do init
7c70: 69 61 6c 20 73 79 6e 63 0a 28 64 65 66 69 6e 65 ial sync.(define
7c80: 20 28 75 6c 65 78 64 62 2d 73 79 6e 63 20 64 62 (ulexdb-sync db
7c90: 63 6f 6e 6e 64 61 74 20 75 64 61 74 61 29 0a 20 conndat udata).
7ca0: 20 23 66 29 0a 0a 0a 29 20 3b 3b 20 45 4e 44 20 #f)...) ;; END
7cb0: 4f 46 20 55 4c 45 58 0a 0a 0a 3b 3b 3b 20 3b 3b OF ULEX...;;; ;;
7cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d00: 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 44 20 ======.;;; ;; D
7d10: 45 20 42 20 55 20 47 20 20 20 48 20 45 20 4c 20 E B U G H E L
7d20: 50 20 45 20 52 20 53 0a 3b 3b 3b 20 3b 3b 3d 3d P E R S.;;; ;;==
7d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d70: 3d 3d 3d 3d 0a 3b 3b 3b 20 20 20 20 20 0a 3b 3b ====.;;; .;;
7d80: 3b 20 28 64 65 66 69 6e 65 20 28 64 62 67 3e 20 ; (define (dbg>
7d90: 2e 20 61 72 67 73 29 0a 3b 3b 3b 20 20 20 28 77 . args).;;; (w
7da0: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
7db0: 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f rt (current-erro
7dc0: 72 2d 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 20 20 r-port).;;;
7dd0: 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 20 (lambda ().;;;
7de0: 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e (apply prin
7df0: 74 20 22 64 62 67 3e 20 22 20 61 72 67 73 29 29 t "dbg> " args))
7e00: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 )).;;; .;;; (def
7e10: 69 6e 65 20 28 64 65 62 75 67 2d 70 70 20 2e 20 ine (debug-pp .
7e20: 61 72 67 73 29 0a 3b 3b 3b 20 20 20 28 69 66 20 args).;;; (if
7e30: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
7e40: 2d 76 61 72 69 61 62 6c 65 20 22 55 4c 45 58 5f -variable "ULEX_
7e50: 44 45 42 55 47 22 29 0a 3b 3b 3b 20 20 20 20 20 DEBUG").;;;
7e60: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
7e70: 6f 2d 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d o-port (current-
7e80: 65 72 72 6f 72 2d 70 6f 72 74 29 0a 3b 3b 3b 20 error-port).;;;
7e90: 09 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 .(lambda ().;;;
7ea0: 09 20 20 28 61 70 70 6c 79 20 70 70 20 61 72 67 . (apply pp arg
7eb0: 73 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 s))))).;;; .;;;
7ec0: 28 64 65 66 69 6e 65 20 2a 64 65 66 61 75 6c 74 (define *default
7ed0: 2d 64 65 62 75 67 2d 70 6f 72 74 2a 20 28 63 75 -debug-port* (cu
7ee0: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
7ef0: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 )).;;; .;;; (def
7f00: 69 6e 65 20 28 73 64 62 67 3e 20 66 6e 20 73 74 ine (sdbg> fn st
7f10: 61 67 65 2d 6e 61 6d 65 20 73 74 61 67 65 2d 73 age-name stage-s
7f20: 74 61 72 74 20 73 74 61 67 65 2d 65 6e 64 20 73 tart stage-end s
7f30: 74 61 72 74 2d 74 69 6d 65 20 2e 20 6d 65 73 73 tart-time . mess
7f40: 61 67 65 29 0a 3b 3b 3b 20 20 20 28 69 66 20 28 age).;;; (if (
7f50: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
7f60: 76 61 72 69 61 62 6c 65 20 22 55 4c 45 58 5f 44 variable "ULEX_D
7f70: 45 42 55 47 22 29 0a 3b 3b 3b 20 20 20 20 20 20 EBUG").;;;
7f80: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
7f90: 2d 70 6f 72 74 20 2a 64 65 66 61 75 6c 74 2d 64 -port *default-d
7fa0: 65 62 75 67 2d 70 6f 72 74 2a 20 0a 3b 3b 3b 20 ebug-port* .;;;
7fb0: 09 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 .(lambda ().;;;
7fc0: 09 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 . (apply print
7fd0: 22 75 6c 65 78 3a 22 20 66 6e 20 22 20 22 20 73 "ulex:" fn " " s
7fe0: 74 61 67 65 2d 6e 61 6d 65 20 22 20 74 6f 6f 6b tage-name " took
7ff0: 20 22 20 28 2d 20 28 69 66 20 73 74 61 67 65 2d " (- (if stage-
8000: 65 6e 64 20 73 74 61 67 65 2d 65 6e 64 20 28 63 end stage-end (c
8010: 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
8020: 6e 64 73 29 29 20 73 74 61 67 65 2d 73 74 61 72 nds)) stage-star
8030: 74 29 20 22 20 6d 73 2e 20 22 0a 3b 3b 3b 20 09 t) " ms. ".;;; .
8040: 09 20 28 69 66 20 73 74 61 72 74 2d 74 69 6d 65 . (if start-time
8050: 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 63 6f 6e .;;; .. (con
8060: 63 20 22 74 6f 74 61 6c 20 74 69 6d 65 20 22 20 c "total time "
8070: 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (- (current-mill
8080: 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d iseconds) start-
8090: 74 69 6d 65 29 0a 3b 3b 3b 20 09 09 09 20 20 20 time).;;; ...
80a0: 22 20 6d 73 2e 22 29 0a 3b 3b 3b 20 09 09 20 20 " ms.").;;; ..
80b0: 20 20 20 22 22 29 0a 3b 3b 3b 20 09 09 20 6d 65 "").;;; .. me
80c0: 73 73 61 67 65 0a 3b 3b 3b 20 09 09 20 29 29 29 ssage.;;; .. )))
80d0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
80e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
8120: 4d 20 41 20 43 20 52 20 4f 20 53 0a 3b 3b 3d 3d M A C R O S.;;==
8130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8170: 3d 3d 3d 3d 0a 3b 3b 20 69 75 70 20 63 61 6c 6c ====.;; iup call
8180: 62 61 63 6b 73 20 61 72 65 20 6e 6f 74 20 64 75 backs are not du
8190: 6d 70 69 6e 67 20 74 68 65 20 73 74 61 63 6b 2c mping the stack,
81a0: 20 74 68 69 73 20 69 73 20 61 20 77 6f 72 6b 2d this is a work-
81b0: 61 72 6f 75 6e 64 0a 3b 3b 0a 0a 3b 3b 20 53 6f around.;;..;; So
81c0: 6d 65 20 6f 66 20 74 68 65 73 65 20 72 6f 75 74 me of these rout
81d0: 69 6e 65 73 20 75 73 65 3a 0a 3b 3b 0a 3b 3b 20 ines use:.;;.;;
81e0: 20 20 20 20 68 74 74 70 3a 2f 2f 77 77 77 2e 63 http://www.c
81f0: 73 2e 74 6f 72 6f 6e 74 6f 2e 65 64 75 2f 7e 67 s.toronto.edu/~g
8200: 66 62 2f 73 63 68 65 6d 65 2f 73 69 6d 70 6c 65 fb/scheme/simple
8210: 2d 6d 61 63 72 6f 73 2e 68 74 6d 6c 0a 3b 3b 0a -macros.html.;;.
8220: 3b 3b 20 53 79 6e 74 61 78 20 66 6f 72 20 64 65 ;; Syntax for de
8230: 66 69 6e 69 6e 67 20 6d 61 63 72 6f 73 20 69 6e fining macros in
8240: 20 61 20 73 69 6d 70 6c 65 20 73 74 79 6c 65 20 a simple style
8250: 73 69 6d 69 6c 61 72 20 74 6f 20 66 75 6e 63 74 similar to funct
8260: 69 6f 6e 20 64 65 66 69 6e 69 74 6f 6e 2c 0a 3b ion definiton,.;
8270: 3b 20 20 77 68 65 6e 20 74 68 65 72 65 20 69 73 ; when there is
8280: 20 61 20 73 69 6e 67 6c 65 20 70 61 74 74 65 72 a single patter
8290: 6e 20 66 6f 72 20 74 68 65 20 61 72 67 75 6d 65 n for the argume
82a0: 6e 74 20 6c 69 73 74 20 61 6e 64 20 74 68 65 72 nt list and ther
82b0: 65 20 61 72 65 20 6e 6f 20 6b 65 79 77 6f 72 64 e are no keyword
82c0: 73 2e 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 s..;;.;; (define
82d0: 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 61 78 20 28 -simple-syntax (
82e0: 6e 61 6d 65 20 61 72 67 20 2e 2e 2e 29 20 62 6f name arg ...) bo
82f0: 64 79 20 2e 2e 2e 29 0a 3b 3b 0a 3b 3b 20 0a 3b dy ...).;;.;; .;
8300: 3b 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 ; (define-syntax
8310: 20 64 65 66 69 6e 65 2d 73 69 6d 70 6c 65 2d 73 define-simple-s
8320: 79 6e 74 61 78 0a 3b 3b 20 20 20 28 73 79 6e 74 yntax.;; (synt
8330: 61 78 2d 72 75 6c 65 73 20 28 29 0a 3b 3b 20 20 ax-rules ().;;
8340: 20 20 20 28 28 5f 20 28 6e 61 6d 65 20 61 72 67 ((_ (name arg
8350: 20 2e 2e 2e 29 20 62 6f 64 79 20 2e 2e 2e 29 0a ...) body ...).
8360: 3b 3b 20 20 20 20 20 20 28 64 65 66 69 6e 65 2d ;; (define-
8370: 73 79 6e 74 61 78 20 6e 61 6d 65 20 28 73 79 6e syntax name (syn
8380: 74 61 78 2d 72 75 6c 65 73 20 28 29 20 28 28 6e tax-rules () ((n
8390: 61 6d 65 20 61 72 67 20 2e 2e 2e 29 20 28 62 65 ame arg ...) (be
83a0: 67 69 6e 20 62 6f 64 79 20 2e 2e 2e 29 29 29 29 gin body ...))))
83b0: 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 ))).;; .;; (defi
83c0: 6e 65 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 61 78 ne-simple-syntax
83d0: 20 28 63 61 74 63 68 2d 61 6e 64 2d 64 75 6d 70 (catch-and-dump
83e0: 20 70 72 6f 63 20 70 72 6f 63 6e 61 6d 65 29 0a proc procname).
83f0: 3b 3b 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 ;; (handle-exc
8400: 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 20 65 78 eptions.;; ex
8410: 6e 0a 3b 3b 20 20 20 20 28 62 65 67 69 6e 0a 3b n.;; (begin.;
8420: 3b 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 ; (print-ca
8430: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
8440: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 3b t-error-port)).;
8450: 3b 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 ; (with-out
8460: 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 63 75 72 put-to-port (cur
8470: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
8480: 0a 3b 3b 20 20 20 20 20 20 20 20 28 6c 61 6d 62 .;; (lamb
8490: 64 61 20 28 29 0a 3b 3b 20 20 20 20 20 20 20 20 da ().;;
84a0: 20 20 28 70 72 69 6e 74 20 28 28 63 6f 6e 64 69 (print ((condi
84b0: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
84c0: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
84d0: 73 61 67 65 29 20 65 78 6e 29 29 0a 3b 3b 20 20 sage) exn)).;;
84e0: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
84f0: 43 61 6c 6c 62 61 63 6b 20 65 72 72 6f 72 20 69 Callback error i
8500: 6e 20 22 20 70 72 6f 63 6e 61 6d 65 29 0a 3b 3b n " procname).;;
8510: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
8520: 20 22 46 75 6c 6c 20 63 6f 6e 64 69 74 69 6f 6e "Full condition
8530: 20 69 6e 66 6f 3a 5c 6e 22 20 28 63 6f 6e 64 69 info:\n" (condi
8540: 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 tion->list exn))
8550: 29 29 29 0a 3b 3b 20 20 20 20 28 70 72 6f 63 29 ))).;; (proc)
8560: 29 29 0a 3b 3b 20 0a 3b 3b 20 0a 3b 3b 3d 3d 3d )).;; .;; .;;===
8570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85b0: 3d 3d 3d 0a 3b 3b 20 20 52 20 45 20 43 20 4f 20 ===.;; R E C O
85c0: 52 20 44 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d R D S.;;========
85d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
8610: 3b 3b 3b 20 3b 3b 20 69 6e 66 6f 72 6d 61 74 69 ;;; ;; informati
8620: 6f 6e 20 61 62 6f 75 74 20 6d 65 20 61 73 20 61 on about me as a
8630: 20 73 65 72 76 65 72 0a 3b 3b 3b 20 3b 3b 0a 3b server.;;; ;;.;
8640: 3b 3b 20 28 64 65 66 73 74 72 75 63 74 20 61 72 ;; (defstruct ar
8650: 65 61 0a 3b 3b 3b 20 20 20 3b 3b 20 61 62 6f 75 ea.;;; ;; abou
8660: 74 20 74 68 69 73 20 61 72 65 61 0a 3b 3b 3b 20 t this area.;;;
8670: 20 20 28 75 73 65 70 6f 72 74 6c 6f 67 67 65 72 (useportlogger
8680: 20 23 66 29 0a 3b 3b 3b 20 20 20 28 6c 6f 77 70 #f).;;; (lowp
8690: 6f 72 74 20 20 20 20 20 20 20 33 32 37 36 38 29 ort 32768)
86a0: 0a 3b 3b 3b 20 20 20 28 73 65 72 76 65 72 2d 74 .;;; (server-t
86b0: 79 70 65 20 20 20 27 61 75 74 6f 29 20 20 3b 3b ype 'auto) ;;
86c0: 20 61 75 74 6f 3d 63 72 65 61 74 65 20 75 70 20 auto=create up
86d0: 74 6f 20 66 69 76 65 20 73 65 72 76 65 72 73 2f to five servers/
86e0: 70 6b 74 73 2c 20 6d 61 69 6e 3d 63 72 65 61 74 pkts, main=creat
86f0: 65 20 70 6b 74 73 2c 20 70 61 73 73 69 76 65 3d e pkts, passive=
8700: 6e 6f 20 70 6b 74 20 28 75 6e 6c 65 73 73 20 74 no pkt (unless t
8710: 68 65 72 65 20 61 72 65 20 6e 6f 20 70 6b 74 73 here are no pkts
8720: 20 61 74 20 61 6c 6c 29 0a 3b 3b 3b 20 20 20 28 at all).;;; (
8730: 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 23 66 conn #f
8740: 29 0a 3b 3b 3b 20 20 20 28 70 6f 72 74 20 20 20 ).;;; (port
8750: 20 20 20 20 20 20 20 23 66 29 0a 3b 3b 3b 20 20 #f).;;;
8760: 20 28 6d 79 61 64 64 72 20 20 20 20 20 20 20 20 (myaddr
8770: 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 (get-my-best-add
8780: 72 65 73 73 29 29 0a 3b 3b 3b 20 20 20 70 6b 74 ress)).;;; pkt
8790: 69 64 20 20 20 20 20 20 20 20 20 20 3b 3b 20 67 id ;; g
87a0: 65 74 20 70 6b 74 20 66 72 6f 6d 20 68 6f 73 74 et pkt from host
87b0: 73 20 74 61 62 6c 65 20 69 66 20 6e 65 65 64 65 s table if neede
87c0: 64 0a 3b 3b 3b 20 20 20 70 6b 74 66 69 6c 65 0a d.;;; pktfile.
87d0: 3b 3b 3b 20 20 20 70 6b 74 73 64 69 72 0a 3b 3b ;;; pktsdir.;;
87e0: 3b 20 20 20 64 62 64 69 72 0a 3b 3b 3b 20 20 20 ; dbdir.;;;
87f0: 28 64 62 68 61 6e 64 6c 65 73 20 20 20 20 20 28 (dbhandles (
8800: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
8810: 29 20 3b 3b 20 66 6e 61 6d 65 20 3d 3e 20 6c 69 ) ;; fname => li
8820: 73 74 2d 6f 66 2d 64 62 68 2c 20 4e 4f 54 45 3a st-of-dbh, NOTE:
8830: 20 53 68 6f 75 6c 64 20 72 65 61 6c 6c 79 20 6e Should really n
8840: 65 76 65 72 20 6e 65 65 64 20 6d 6f 72 65 20 74 ever need more t
8850: 68 61 6e 20 6f 6e 65 3f 0a 3b 3b 3b 20 20 20 28 han one?.;;; (
8860: 6d 75 74 65 78 20 20 20 20 20 20 20 20 20 28 6d mutex (m
8870: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 3b 3b 3b 20 ake-mutex)).;;;
8880: 20 20 28 72 74 61 62 6c 65 20 20 20 20 20 20 20 (rtable
8890: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
88a0: 65 29 29 20 3b 3b 20 72 65 67 69 73 74 72 61 74 e)) ;; registrat
88b0: 69 6f 6e 20 74 61 62 6c 65 20 6f 66 20 61 76 61 ion table of ava
88c0: 69 6c 61 62 6c 65 20 61 63 74 69 6f 6e 73 0a 3b ilable actions.;
88d0: 3b 3b 20 20 20 28 64 62 73 20 20 20 20 20 20 20 ;; (dbs
88e0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
88f0: 61 62 6c 65 29 29 20 3b 3b 20 66 69 6c 65 6e 61 able)) ;; filena
8900: 6d 65 20 3d 3e 20 72 61 6e 64 6f 6d 20 6e 75 6d me => random num
8910: 62 65 72 2c 20 75 73 65 64 20 66 6f 72 20 63 68 ber, used for ch
8920: 6f 6f 73 69 6e 67 20 77 68 61 74 20 64 62 73 20 oosing what dbs
8930: 49 20 73 65 72 76 65 0a 3b 3b 3b 20 20 20 3b 3b I serve.;;; ;;
8940: 20 61 62 6f 75 74 20 6f 74 68 65 72 20 73 65 72 about other ser
8950: 76 65 72 73 0a 3b 3b 3b 20 20 20 28 68 6f 73 74 vers.;;; (host
8960: 73 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d s (make-
8970: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
8980: 6b 65 79 20 3d 3e 20 68 6f 73 74 64 61 74 0a 3b key => hostdat.;
8990: 3b 3b 20 20 20 28 68 6f 73 74 73 74 61 74 73 20 ;; (hoststats
89a0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
89b0: 61 62 6c 65 29 29 20 3b 3b 20 6b 65 79 20 3d 3e able)) ;; key =>
89c0: 20 61 6c 69 73 74 20 6f 66 20 66 6e 61 6d 65 20 alist of fname
89d0: 3d 3e 20 28 20 71 63 6f 75 6e 74 20 2e 20 71 74 => ( qcount . qt
89e0: 69 6d 65 20 29 0a 3b 3b 3b 20 20 20 28 72 65 71 ime ).;;; (req
89f0: 73 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 s (make
8a00: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
8a10: 20 75 72 69 20 3d 3e 20 71 75 65 75 65 0a 3b 3b uri => queue.;;
8a20: 3b 20 20 20 3b 3b 20 77 6f 72 6b 20 71 75 65 75 ; ;; work queu
8a30: 65 73 0a 3b 3b 3b 20 20 20 28 77 71 75 65 75 65 es.;;; (wqueue
8a40: 73 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 s (make-ha
8a50: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 66 6e sh-table)) ;; fn
8a60: 61 6d 65 20 3d 3e 20 71 64 61 74 0a 3b 3b 3b 20 ame => qdat.;;;
8a70: 20 20 28 73 74 61 74 73 20 20 20 20 20 20 20 20 (stats
8a80: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
8a90: 65 29 29 20 3b 3b 20 66 6e 61 6d 65 20 3d 3e 20 e)) ;; fname =>
8aa0: 74 6f 74 61 6c 71 75 65 72 69 65 73 0a 3b 3b 3b totalqueries.;;;
8ab0: 20 20 20 28 6c 61 73 74 2d 73 72 76 75 70 20 20 (last-srvup
8ac0: 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e (current-secon
8ad0: 64 73 29 29 20 3b 3b 20 6c 61 73 74 20 74 69 6d ds)) ;; last tim
8ae0: 65 20 77 65 20 75 70 64 61 74 65 64 20 74 68 65 e we updated the
8af0: 20 6b 6e 6f 77 6e 20 73 65 72 76 65 72 73 0a 3b known servers.;
8b00: 3b 3b 20 20 20 28 63 6f 6f 6b 69 65 32 6d 62 6f ;; (cookie2mbo
8b10: 78 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 x (make-hash-t
8b20: 61 62 6c 65 29 29 20 3b 3b 20 6d 61 70 20 63 6f able)) ;; map co
8b30: 6f 6b 69 65 20 66 6f 72 20 6f 75 74 73 74 61 6e okie for outstan
8b40: 64 69 6e 67 20 72 65 71 75 65 73 74 20 74 6f 20 ding request to
8b50: 6d 61 69 6c 62 6f 78 20 6f 66 20 61 77 61 69 74 mailbox of await
8b60: 69 6e 67 20 63 61 6c 6c 0a 3b 3b 3b 20 20 20 28 ing call.;;; (
8b70: 72 65 61 64 79 20 23 66 29 0a 3b 3b 3b 20 20 20 ready #f).;;;
8b80: 28 68 65 61 6c 74 68 20 20 20 20 20 20 20 20 28 (health (
8b90: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
8ba0: 29 20 3b 3b 20 69 70 61 64 64 72 3a 70 6f 72 74 ) ;; ipaddr:port
8bb0: 20 3d 3e 20 6e 75 6d 20 66 61 69 6c 65 64 20 70 => num failed p
8bc0: 69 6e 67 73 20 73 69 6e 63 65 20 6c 61 73 74 20 ings since last
8bd0: 67 6f 6f 64 20 70 69 6e 67 0a 3b 3b 3b 20 20 20 good ping.;;;
8be0: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 68 6f ).;;; .;;; ;; ho
8bf0: 73 74 20 73 74 61 74 73 0a 3b 3b 3b 20 3b 3b 0a st stats.;;; ;;.
8c00: 3b 3b 3b 20 28 64 65 66 73 74 72 75 63 74 20 68 ;;; (defstruct h
8c10: 6f 73 74 64 61 74 0a 3b 3b 3b 20 20 20 28 70 6b ostdat.;;; (pk
8c20: 74 20 20 20 20 20 20 23 66 29 0a 3b 3b 3b 20 20 t #f).;;;
8c30: 20 28 64 62 6c 6f 61 64 20 20 20 28 6d 61 6b 65 (dbload (make
8c40: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 20 3b -hash-table)) ;
8c50: 3b 20 22 64 62 66 69 6c 65 2e 64 62 22 20 3d 3e ; "dbfile.db" =>
8c60: 20 71 75 65 72 69 65 73 2f 6d 69 6e 0a 3b 3b 3b queries/min.;;;
8c70: 20 20 20 28 68 6f 73 74 6c 6f 61 64 20 23 66 29 (hostload #f)
8c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c90: 20 3b 3b 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 6c ;; normalized l
8ca0: 6f 61 64 20 28 20 35 6d 69 6e 20 6c 6f 61 64 20 oad ( 5min load
8cb0: 2f 20 6e 75 6d 63 70 75 73 20 29 0a 3b 3b 3b 20 / numcpus ).;;;
8cc0: 20 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 ).;;; .;;; ;;
8cd0: 64 62 64 61 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b dbdat.;;; ;;.;;;
8ce0: 20 28 64 65 66 73 74 72 75 63 74 20 64 62 64 61 (defstruct dbda
8cf0: 74 0a 3b 3b 3b 20 20 20 28 64 62 68 20 20 20 20 t.;;; (dbh
8d00: 23 66 29 0a 3b 3b 3b 20 20 20 28 66 6e 61 6d 65 #f).;;; (fname
8d10: 20 20 23 66 29 0a 3b 3b 3b 20 20 20 28 77 72 69 #f).;;; (wri
8d20: 74 65 2d 61 63 63 65 73 73 20 23 66 29 0a 3b 3b te-access #f).;;
8d30: 3b 20 20 20 28 73 74 68 73 20 20 20 28 6d 61 6b ; (sths (mak
8d40: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 20 e-hash-table))
8d50: 3b 3b 20 68 61 73 68 20 6d 61 70 70 69 6e 67 20 ;; hash mapping
8d60: 71 75 65 72 79 20 73 74 72 69 6e 67 73 20 74 6f query strings to
8d70: 20 68 61 6e 64 6c 65 73 0a 3b 3b 3b 20 20 20 29 handles.;;; )
8d80: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 71 64 61 .;;; .;;; ;; qda
8d90: 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 t.;;; ;;.;;; (de
8da0: 66 73 74 72 75 63 74 20 71 64 61 74 0a 3b 3b 3b fstruct qdat.;;;
8db0: 20 20 20 28 77 72 69 74 65 71 20 20 28 6d 61 6b (writeq (mak
8dc0: 65 2d 71 75 65 75 65 29 29 0a 3b 3b 3b 20 20 20 e-queue)).;;;
8dd0: 28 72 65 61 64 71 20 20 20 28 6d 61 6b 65 2d 71 (readq (make-q
8de0: 75 65 75 65 29 29 0a 3b 3b 3b 20 20 20 28 72 77 ueue)).;;; (rw
8df0: 71 20 20 20 20 20 28 6d 61 6b 65 2d 71 75 65 75 q (make-queu
8e00: 65 29 29 0a 3b 3b 3b 20 20 20 28 6c 6f 67 71 20 e)).;;; (logq
8e10: 20 20 20 28 6d 61 6b 65 2d 71 75 65 75 65 29 29 (make-queue))
8e20: 20 3b 3b 20 64 6f 20 77 65 20 6e 65 65 64 20 61 ;; do we need a
8e30: 20 71 75 65 75 65 20 66 6f 72 20 6c 6f 67 67 69 queue for loggi
8e40: 6e 67 3f 20 79 65 73 2c 20 69 66 20 77 65 20 75 ng? yes, if we u
8e50: 73 65 20 73 71 6c 69 74 65 33 20 64 62 20 66 6f se sqlite3 db fo
8e60: 72 20 6c 6f 67 67 69 6e 67 0a 3b 3b 3b 20 20 20 r logging.;;;
8e70: 28 6f 73 73 68 6f 72 74 20 28 6d 61 6b 65 2d 71 (osshort (make-q
8e80: 75 65 75 65 29 29 0a 3b 3b 3b 20 20 20 28 6f 73 ueue)).;;; (os
8e90: 6c 6f 6e 67 20 20 28 6d 61 6b 65 2d 71 75 65 75 long (make-queu
8ea0: 65 29 29 0a 3b 3b 3b 20 20 20 28 6d 69 73 63 20 e)).;;; (misc
8eb0: 20 20 20 28 6d 61 6b 65 2d 71 75 65 75 65 29 29 (make-queue))
8ec0: 20 3b 3b 20 75 73 65 64 20 66 6f 72 20 74 68 69 ;; used for thi
8ed0: 6e 67 73 20 6c 69 6b 65 20 70 69 6e 67 2d 66 75 ngs like ping-fu
8ee0: 6c 6c 0a 3b 3b 3b 20 20 20 29 0a 3b 3b 3b 20 0a ll.;;; ).;;; .
8ef0: 3b 3b 3b 20 3b 3b 20 63 61 6c 6c 64 61 74 0a 3b ;;; ;; calldat.;
8f00: 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 73 74 ;; ;;.;;; (defst
8f10: 72 75 63 74 20 63 61 6c 6c 64 61 74 0a 3b 3b 3b ruct calldat.;;;
8f20: 20 20 20 28 63 74 79 70 65 20 27 64 62 77 72 69 (ctype 'dbwri
8f30: 74 65 29 0a 3b 3b 3b 20 20 20 28 6f 62 6a 20 20 te).;;; (obj
8f40: 20 23 66 29 20 20 20 20 20 20 20 20 20 20 20 20 #f)
8f50: 20 20 3b 3b 20 74 68 69 73 20 77 6f 75 6c 64 20 ;; this would
8f60: 6e 6f 72 6d 61 6c 6c 79 20 62 65 20 61 6e 20 53 normally be an S
8f70: 51 4c 20 73 74 61 74 65 6d 65 6e 74 20 65 2e 67 QL statement e.g
8f80: 2e 20 53 45 4c 45 43 54 2c 20 49 4e 53 45 52 54 . SELECT, INSERT
8f90: 20 65 74 63 2e 0a 3b 3b 3b 20 20 20 28 72 74 69 etc..;;; (rti
8fa0: 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c me (current-mill
8fb0: 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 iseconds))).;;;
8fc0: 0a 3b 3b 3b 20 3b 3b 20 6d 61 6b 65 20 69 74 20 .;;; ;; make it
8fd0: 61 20 67 6c 6f 62 61 6c 3f 20 57 65 6c 6c 2c 20 a global? Well,
8fe0: 69 74 20 69 73 20 6c 6f 63 61 6c 20 74 6f 20 61 it is local to a
8ff0: 72 65 61 20 6d 6f 64 75 6c 65 0a 3b 3b 3b 20 0a rea module.;;; .
9000: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 2a 70 6b 74 ;;; (define *pkt
9010: 73 70 65 63 2a 0a 3b 3b 3b 20 20 20 60 28 28 73 spec*.;;; `((s
9020: 65 72 76 65 72 20 28 68 6f 73 74 6e 61 6d 65 20 erver (hostname
9030: 2e 20 68 29 0a 3b 3b 3b 20 09 20 20 20 20 28 70 . h).;;; . (p
9040: 6f 72 74 20 20 20 20 20 2e 20 70 29 0a 3b 3b 3b ort . p).;;;
9050: 20 09 20 20 20 20 28 70 69 64 20 20 20 20 20 20 . (pid
9060: 2e 20 69 29 0a 3b 3b 3b 20 09 20 20 20 20 28 69 . i).;;; . (i
9070: 70 61 64 64 72 20 20 20 2e 20 61 29 0a 3b 3b 3b paddr . a).;;;
9080: 20 09 20 20 20 20 29 0a 3b 3b 3b 20 20 20 20 20 . ).;;;
9090: 28 64 61 74 61 20 20 20 28 68 6f 73 74 6e 61 6d (data (hostnam
90a0: 65 20 2e 20 68 29 20 20 3b 3b 20 73 65 6e 64 65 e . h) ;; sende
90b0: 72 20 68 6f 73 74 6e 61 6d 65 0a 3b 3b 3b 20 09 r hostname.;;; .
90c0: 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 2e 20 (port .
90d0: 70 29 20 20 3b 3b 20 73 65 6e 64 65 72 20 70 6f p) ;; sender po
90e0: 72 74 0a 3b 3b 3b 20 09 20 20 20 20 28 69 70 61 rt.;;; . (ipa
90f0: 64 64 72 20 20 20 2e 20 61 29 20 20 3b 3b 20 73 ddr . a) ;; s
9100: 65 6e 64 65 72 20 69 70 0a 3b 3b 3b 20 09 20 20 ender ip.;;; .
9110: 20 20 28 68 6f 73 74 6b 65 79 20 20 2e 20 6b 29 (hostkey . k)
9120: 20 20 3b 3b 20 73 65 6e 64 69 6e 67 20 68 6f 73 ;; sending hos
9130: 74 20 6b 65 79 20 2d 20 73 74 6f 72 65 20 69 6e t key - store in
9140: 66 6f 20 61 74 20 73 65 72 76 65 72 20 75 6e 64 fo at server und
9150: 65 72 20 74 68 69 73 20 6b 65 79 0a 3b 3b 3b 20 er this key.;;;
9160: 09 20 20 20 20 28 73 65 72 76 6b 65 79 20 20 2e . (servkey .
9170: 20 73 29 20 20 3b 3b 20 73 65 72 76 65 72 20 6b s) ;; server k
9180: 65 79 20 2d 20 74 68 69 73 20 6e 65 65 64 73 20 ey - this needs
9190: 74 6f 20 6d 61 74 63 68 20 61 74 20 73 65 72 76 to match at serv
91a0: 65 72 20 65 6e 64 20 6f 72 20 72 65 6a 65 63 74 er end or reject
91b0: 20 74 68 65 20 6d 73 67 0a 3b 3b 3b 20 09 20 20 the msg.;;; .
91c0: 20 20 28 66 6f 72 6d 61 74 20 20 20 2e 20 66 29 (format . f)
91d0: 20 20 3b 3b 20 73 62 3d 73 65 72 69 61 6c 69 7a ;; sb=serializ
91e0: 65 64 2d 62 61 73 65 36 34 2c 20 74 3d 74 65 78 ed-base64, t=tex
91f0: 74 2c 20 73 78 3d 73 65 78 70 72 2c 20 6a 3d 6a t, sx=sexpr, j=j
9200: 73 6f 6e 0a 3b 3b 3b 20 09 20 20 20 20 28 64 61 son.;;; . (da
9210: 74 61 20 20 20 20 20 2e 20 64 29 20 20 3b 3b 20 ta . d) ;;
9220: 62 61 73 65 36 34 20 65 6e 63 6f 64 65 64 20 73 base64 encoded s
9230: 6c 6c 6e 20 64 61 74 61 0a 3b 3b 3b 20 09 20 20 lln data.;;; .
9240: 20 20 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b ))).;;; .;;; ;
9250: 3b 20 77 6f 72 6b 20 69 74 65 6d 0a 3b 3b 3b 20 ; work item.;;;
9260: 3b 3b 0a 3b 3b 3b 20 28 64 65 66 73 74 72 75 63 ;;.;;; (defstruc
9270: 74 20 77 69 74 65 6d 0a 3b 3b 3b 20 20 20 28 72 t witem.;;; (r
9280: 68 6f 73 74 20 23 66 29 20 20 20 3b 3b 20 72 65 host #f) ;; re
9290: 74 75 72 6e 20 68 6f 73 74 0a 3b 3b 3b 20 20 20 turn host.;;;
92a0: 28 72 69 70 61 64 64 72 20 23 66 29 20 3b 3b 20 (ripaddr #f) ;;
92b0: 72 65 74 75 72 6e 20 69 70 61 64 64 72 0a 3b 3b return ipaddr.;;
92c0: 3b 20 20 20 28 72 70 6f 72 74 20 23 66 29 20 20 ; (rport #f)
92d0: 20 3b 3b 20 72 65 74 75 72 6e 20 70 6f 72 74 0a ;; return port.
92e0: 3b 3b 3b 20 20 20 28 73 65 72 76 6b 65 79 20 23 ;;; (servkey #
92f0: 66 29 20 3b 3b 20 74 68 65 20 70 61 63 6b 65 74 f) ;; the packet
9300: 20 72 65 70 72 65 73 65 6e 74 69 6e 67 20 74 68 representing th
9310: 65 20 63 6c 69 65 6e 74 20 6f 66 20 74 68 69 73 e client of this
9320: 20 77 6f 72 6b 69 74 65 6d 2c 20 75 73 65 64 20 workitem, used
9330: 62 79 20 66 69 6e 61 6c 20 73 65 6e 64 2d 6d 65 by final send-me
9340: 73 73 61 67 65 0a 3b 3b 3b 20 20 20 28 72 64 61 ssage.;;; (rda
9350: 74 20 20 23 66 29 20 20 20 3b 3b 20 74 68 65 20 t #f) ;; the
9360: 72 65 71 75 65 73 74 20 2d 20 75 73 75 61 6c 6c request - usuall
9370: 79 20 61 6e 20 73 71 6c 20 71 75 65 72 79 2c 20 y an sql query,
9380: 74 79 70 65 20 69 73 20 72 64 61 74 0a 3b 3b 3b type is rdat.;;;
9390: 20 20 20 28 61 63 74 69 6f 6e 20 23 66 29 20 20 (action #f)
93a0: 3b 3b 20 74 68 65 20 61 63 74 69 6f 6e 3a 20 69 ;; the action: i
93b0: 6d 6d 65 64 69 61 74 65 2c 20 64 62 77 72 69 74 mmediate, dbwrit
93c0: 65 2c 20 64 62 72 65 61 64 2c 6f 73 6c 6f 6e 67 e, dbread,oslong
93d0: 2c 20 6f 73 73 68 6f 72 74 0a 3b 3b 3b 20 20 20 , osshort.;;;
93e0: 28 63 6f 6f 6b 69 65 20 23 66 29 20 20 3b 3b 20 (cookie #f) ;;
93f0: 63 6f 6f 6b 69 65 20 69 64 20 66 6f 72 20 72 65 cookie id for re
9400: 73 70 6f 6e 73 65 0a 3b 3b 3b 20 20 20 28 64 61 sponse.;;; (da
9410: 74 61 20 20 20 23 66 29 20 20 3b 3b 20 74 68 65 ta #f) ;; the
9420: 20 64 61 74 61 20 70 61 79 6c 6f 61 64 2c 20 69 data payload, i
9430: 2e 65 2e 20 70 61 72 61 6d 65 74 65 72 73 0a 3b .e. parameters.;
9440: 3b 3b 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 ;; (result #f)
9450: 20 20 3b 3b 20 74 68 65 20 72 65 73 75 6c 74 20 ;; the result
9460: 66 72 6f 6d 20 70 72 6f 63 65 73 73 69 6e 67 20 from processing
9470: 74 68 65 20 64 61 74 61 0a 3b 3b 3b 20 20 20 28 the data.;;; (
9480: 63 61 6c 6c 65 72 20 23 66 29 29 20 3b 3b 20 74 caller #f)) ;; t
9490: 68 65 20 63 61 6c 6c 69 6e 67 20 70 65 65 72 20 he calling peer
94a0: 61 63 63 6f 72 64 69 6e 67 20 74 6f 20 72 70 63 according to rpc
94b0: 20 69 74 73 65 6c 66 0a 3b 3b 3b 20 0a 3b 3b 3b itself.;;; .;;;
94c0: 20 28 64 65 66 69 6e 65 20 28 74 72 69 6d 2d 70 (define (trim-p
94d0: 6b 74 69 64 20 70 6b 74 69 64 29 0a 3b 3b 3b 20 ktid pktid).;;;
94e0: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 (if (string? p
94f0: 6b 74 69 64 29 0a 3b 3b 3b 20 20 20 20 20 20 20 ktid).;;;
9500: 28 73 75 62 73 74 72 69 6e 67 20 70 6b 74 69 64 (substring pktid
9510: 20 30 20 34 29 0a 3b 3b 3b 20 20 20 20 20 20 20 0 4).;;;
9520: 22 6e 6f 70 6b 74 22 29 29 0a 3b 3b 3b 20 0a 3b "nopkt")).;;; .;
9530: 3b 3b 20 28 64 65 66 69 6e 65 20 28 61 6e 79 2d ;; (define (any-
9540: 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 0a 3b 3b 3b >number num).;;;
9550: 20 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 20 20 20 (cond.;;;
9560: 28 28 6e 75 6d 62 65 72 3f 20 6e 75 6d 29 20 6e ((number? num) n
9570: 75 6d 29 0a 3b 3b 3b 20 20 20 20 28 28 73 74 72 um).;;; ((str
9580: 69 6e 67 3f 20 6e 75 6d 29 20 28 73 74 72 69 6e ing? num) (strin
9590: 67 2d 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 29 0a g->number num)).
95a0: 3b 3b 3b 20 20 20 20 28 65 6c 73 65 20 6e 75 6d ;;; (else num
95b0: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 75 73 ))).;;; .;;; (us
95c0: 65 20 74 72 61 63 65 29 0a 3b 3b 3b 20 28 74 72 e trace).;;; (tr
95d0: 61 63 65 2d 63 61 6c 6c 2d 73 69 74 65 73 20 23 ace-call-sites #
95e0: 74 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d t).;;; .;;; ;;==
95f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9630: 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 44 20 41 20 ====.;;; ;; D A
9640: 54 20 41 20 42 20 41 20 53 20 45 20 20 20 48 20 T A B A S E H
9650: 41 20 4e 20 44 20 4c 20 49 20 4e 20 47 20 0a 3b A N D L I N G .;
9660: 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;; ;;===========
9670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
96a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 ===========.;;;
96b0: 0a 3b 3b 3b 20 3b 3b 20 6c 6f 6f 6b 20 69 6e 20 .;;; ;; look in
96c0: 64 62 68 61 6e 64 6c 65 73 20 66 6f 72 20 61 20 dbhandles for a
96d0: 64 62 2c 20 72 65 74 75 72 6e 20 69 74 2c 20 65 db, return it, e
96e0: 6c 73 65 20 72 65 74 75 72 6e 20 23 66 0a 3b 3b lse return #f.;;
96f0: 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 ; ;;.;;; (define
9700: 20 28 67 65 74 2d 64 62 68 20 61 63 66 67 20 66 (get-dbh acfg f
9710: 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 name).;;; (let
9720: 20 28 28 64 62 68 2d 6c 73 74 20 28 68 61 73 68 ((dbh-lst (hash
9730: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
9740: 6c 74 20 28 61 72 65 61 2d 64 62 68 61 6e 64 6c lt (area-dbhandl
9750: 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 20 27 es acfg) fname '
9760: 28 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 ()))).;;; (i
9770: 66 20 28 6e 75 6c 6c 3f 20 64 62 68 2d 6c 73 74 f (null? dbh-lst
9780: 29 0a 3b 3b 3b 20 09 28 62 65 67 69 6e 0a 3b 3b ).;;; .(begin.;;
9790: 3b 20 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ; . ;; (print "
97a0: 6f 70 65 6e 69 6e 67 20 64 62 20 66 6f 72 20 22 opening db for "
97b0: 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 20 20 28 fname).;;; . (
97c0: 6f 70 65 6e 2d 64 62 20 61 63 66 67 20 66 6e 61 open-db acfg fna
97d0: 6d 65 29 29 20 3b 3b 20 4e 6f 74 65 20 74 68 61 me)) ;; Note tha
97e0: 74 20 74 68 65 20 68 61 6e 64 6c 65 73 20 67 65 t the handles ge
97f0: 74 20 70 75 74 20 62 61 63 6b 20 69 6e 20 74 68 t put back in th
9800: 65 20 71 75 65 75 65 20 69 6e 20 74 68 65 20 73 e queue in the s
9810: 61 76 65 2d 64 62 68 20 63 61 6c 6c 73 0a 3b 3b ave-dbh calls.;;
9820: 3b 20 09 28 6c 65 74 20 28 28 72 65 6d 2d 6c 73 ; .(let ((rem-ls
9830: 74 20 28 63 64 72 20 64 62 68 2d 6c 73 74 29 29 t (cdr dbh-lst))
9840: 29 0a 3b 3b 3b 20 09 20 20 3b 3b 20 28 70 72 69 ).;;; . ;; (pri
9850: 6e 74 20 22 72 65 2d 75 73 69 6e 67 20 73 61 76 nt "re-using sav
9860: 65 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 66 6f ed connection fo
9870: 72 20 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 r " fname).;;; .
9880: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
9890: 74 21 20 28 61 72 65 61 2d 64 62 68 61 6e 64 6c t! (area-dbhandl
98a0: 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 20 72 es acfg) fname r
98b0: 65 6d 2d 6c 73 74 29 0a 3b 3b 3b 20 09 20 20 28 em-lst).;;; . (
98c0: 63 61 72 20 64 62 68 2d 6c 73 74 29 29 29 29 29 car dbh-lst)))))
98d0: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e .;;; .;;; (defin
98e0: 65 20 28 73 61 76 65 2d 64 62 68 20 61 63 66 67 e (save-dbh acfg
98f0: 20 66 6e 61 6d 65 20 64 62 64 61 74 29 0a 3b 3b fname dbdat).;;
9900: 3b 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ; ;; (print
9910: 22 73 61 76 69 6e 67 20 64 62 68 20 66 6f 72 20 "saving dbh for
9920: 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 20 " fname).;;;
9930: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
9940: 21 20 28 61 72 65 61 2d 64 62 68 61 6e 64 6c 65 ! (area-dbhandle
9950: 73 20 61 63 66 67 29 20 66 6e 61 6d 65 20 28 63 s acfg) fname (c
9960: 6f 6e 73 20 64 62 64 61 74 20 28 68 61 73 68 2d ons dbdat (hash-
9970: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
9980: 74 20 28 61 72 65 61 2d 64 62 68 61 6e 64 6c 65 t (area-dbhandle
9990: 73 20 61 63 66 67 29 20 66 6e 61 6d 65 20 27 28 s acfg) fname '(
99a0: 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b ))))).;;; .;;; ;
99b0: 3b 20 6f 70 65 6e 20 74 68 65 20 64 61 74 61 62 ; open the datab
99c0: 61 73 65 2c 20 69 66 20 6e 65 76 65 72 20 62 65 ase, if never be
99d0: 66 6f 72 65 20 6f 70 65 6e 65 64 20 69 6e 69 74 fore opened init
99e0: 20 69 74 2e 20 70 75 74 20 74 68 65 20 68 61 6e it. put the han
99f0: 64 6c 65 20 69 6e 20 74 68 65 0a 3b 3b 3b 20 3b dle in the.;;; ;
9a00: 3b 20 6f 70 65 6e 20 64 62 27 73 20 68 61 73 68 ; open db's hash
9a10: 20 74 61 62 6c 65 0a 3b 3b 3b 20 3b 3b 20 72 65 table.;;; ;; re
9a20: 74 75 72 6e 73 3a 20 74 68 65 20 64 62 64 61 74 turns: the dbdat
9a30: 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 .;;; ;;.;;; (def
9a40: 69 6e 65 20 28 6f 70 65 6e 2d 64 62 20 61 63 66 ine (open-db acf
9a50: 67 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 28 g fname).;;; (
9a60: 6c 65 74 2a 20 28 28 66 75 6c 6c 6e 61 6d 65 20 let* ((fullname
9a70: 20 20 20 20 28 63 6f 6e 63 20 28 61 72 65 61 2d (conc (area-
9a80: 64 62 64 69 72 20 61 63 66 67 29 20 22 2f 22 20 dbdir acfg) "/"
9a90: 66 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 28 65 fname)).;;; . (e
9aa0: 78 69 73 74 73 20 20 20 20 20 20 20 28 66 69 6c xists (fil
9ab0: 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 6e 61 e-exists? fullna
9ac0: 6d 65 29 29 0a 3b 3b 3b 20 09 20 28 77 72 69 74 me)).;;; . (writ
9ad0: 65 2d 61 63 63 65 73 73 20 28 69 66 20 65 78 69 e-access (if exi
9ae0: 73 74 73 0a 3b 3b 3b 20 09 09 09 20 20 20 28 66 sts.;;; ... (f
9af0: 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 ile-write-access
9b00: 3f 20 66 75 6c 6c 6e 61 6d 65 29 0a 3b 3b 3b 20 ? fullname).;;;
9b10: 09 09 09 20 20 20 28 66 69 6c 65 2d 77 72 69 74 ... (file-writ
9b20: 65 2d 61 63 63 65 73 73 3f 20 28 61 72 65 61 2d e-access? (area-
9b30: 64 62 64 69 72 20 61 63 66 67 29 29 29 29 0a 3b dbdir acfg)))).;
9b40: 3b 3b 20 09 20 28 64 62 20 20 20 20 20 20 20 20 ;; . (db
9b50: 20 20 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 6e (sqlite3:open
9b60: 2d 64 61 74 61 62 61 73 65 20 66 75 6c 6c 6e 61 -database fullna
9b70: 6d 65 29 29 0a 3b 3b 3b 20 09 20 28 68 61 6e 64 me)).;;; . (hand
9b80: 6c 65 72 20 20 20 20 20 20 28 73 71 6c 69 74 65 ler (sqlite
9b90: 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 69 6d 65 3:make-busy-time
9ba0: 6f 75 74 20 31 33 36 30 30 30 29 29 0a 3b 3b 3b out 136000)).;;;
9bb0: 20 09 20 29 0a 3b 3b 3b 20 20 20 20 20 28 73 71 . ).;;; (sq
9bc0: 6c 69 74 65 33 3a 73 65 74 2d 62 75 73 79 2d 68 lite3:set-busy-h
9bd0: 61 6e 64 6c 65 72 21 20 64 62 20 68 61 6e 64 6c andler! db handl
9be0: 65 72 29 0a 3b 3b 3b 20 20 20 20 20 28 73 71 6c er).;;; (sql
9bf0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
9c00: 22 50 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e "PRAGMA synchron
9c10: 6f 75 73 20 3d 20 30 3b 22 29 0a 3b 3b 3b 20 20 ous = 0;").;;;
9c20: 20 20 20 28 69 66 20 28 6e 6f 74 20 65 78 69 73 (if (not exis
9c30: 74 73 29 20 3b 3b 20 6e 65 65 64 20 74 6f 20 69 ts) ;; need to i
9c40: 6e 69 74 20 74 68 65 20 64 62 0a 3b 3b 3b 20 09 nit the db.;;; .
9c50: 28 69 66 20 77 72 69 74 65 2d 61 63 63 65 73 73 (if write-access
9c60: 0a 3b 3b 3b 20 09 20 20 20 20 28 6c 65 74 20 28 .;;; . (let (
9c70: 28 69 73 71 6c 20 28 67 65 74 2d 72 73 71 6c 20 (isql (get-rsql
9c80: 61 63 66 67 20 27 64 62 69 6e 69 74 73 71 6c 29 acfg 'dbinitsql)
9c90: 29 29 20 3b 3b 20 67 65 74 20 74 68 65 20 69 6e )) ;; get the in
9ca0: 69 74 20 73 71 6c 20 73 74 61 74 65 6d 65 6e 74 it sql statement
9cb0: 73 0a 3b 3b 3b 20 09 20 20 20 20 20 20 3b 3b 20 s.;;; . ;;
9cc0: 28 73 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 (sqlite3:with-tr
9cd0: 61 6e 73 61 63 74 69 6f 6e 0a 3b 3b 3b 20 09 20 ansaction.;;; .
9ce0: 20 20 20 20 20 3b 3b 20 20 64 62 0a 3b 3b 3b 20 ;; db.;;;
9cf0: 09 20 20 20 20 20 20 3b 3b 20 20 28 6c 61 6d 62 . ;; (lamb
9d00: 64 61 20 28 29 0a 3b 3b 3b 20 09 09 20 28 69 66 da ().;;; .. (if
9d10: 20 69 73 71 6c 0a 3b 3b 3b 20 09 09 20 20 20 20 isql.;;; ..
9d20: 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 09 (for-each.;;; .
9d30: 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
9d40: 73 71 6c 29 0a 3b 3b 3b 20 09 09 09 28 73 71 6c sql).;;; ...(sql
9d50: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
9d60: 73 71 6c 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 sql)).;;; ..
9d70: 20 20 69 73 71 6c 29 29 29 0a 3b 3b 3b 20 09 20 isql))).;;; .
9d80: 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 (print "ERROR
9d90: 3a 20 6e 6f 20 77 72 69 74 65 20 61 63 63 65 73 : no write acces
9da0: 73 20 74 6f 20 22 20 28 61 72 65 61 2d 64 62 64 s to " (area-dbd
9db0: 69 72 20 61 63 66 67 29 29 29 29 0a 3b 3b 3b 20 ir acfg)))).;;;
9dc0: 20 20 20 20 28 6d 61 6b 65 2d 64 62 64 61 74 20 (make-dbdat
9dd0: 64 62 68 3a 20 64 62 20 66 6e 61 6d 65 3a 20 66 dbh: db fname: f
9de0: 6e 61 6d 65 20 77 72 69 74 65 2d 61 63 63 65 73 name write-acces
9df0: 73 3a 20 77 72 69 74 65 2d 61 63 63 65 73 73 29 s: write-access)
9e00: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 54 )).;;; .;;; ;; T
9e10: 68 69 73 20 69 73 20 61 20 6c 6f 77 2d 6c 65 76 his is a low-lev
9e20: 65 6c 20 63 6f 6d 6d 61 6e 64 20 74 6f 20 72 65 el command to re
9e30: 74 72 69 65 76 65 20 6f 72 20 74 6f 20 70 72 65 trieve or to pre
9e40: 70 61 72 65 2c 20 73 61 76 65 20 61 6e 64 20 72 pare, save and r
9e50: 65 74 75 72 6e 20 61 20 70 72 65 70 61 72 65 64 eturn a prepared
9e60: 20 73 74 61 74 6d 65 6e 74 0a 3b 3b 3b 20 3b 3b statment.;;; ;;
9e70: 20 79 6f 75 20 6d 75 73 74 20 65 78 74 72 61 63 you must extrac
9e80: 74 20 74 68 65 20 64 62 20 68 61 6e 64 6c 65 0a t the db handle.
9e90: 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 ;;; ;;.;;; (defi
9ea0: 6e 65 20 28 67 65 74 2d 73 74 68 20 64 62 20 63 ne (get-sth db c
9eb0: 61 63 68 65 20 73 74 6d 74 29 0a 3b 3b 3b 20 20 ache stmt).;;;
9ec0: 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 (if (hash-table
9ed0: 2d 65 78 69 73 74 73 3f 20 63 61 63 68 65 20 73 -exists? cache s
9ee0: 74 6d 74 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 tmt).;;; (
9ef0: 62 65 67 69 6e 0a 3b 3b 3b 20 09 3b 3b 20 28 70 begin.;;; .;; (p
9f00: 72 69 6e 74 20 22 52 65 75 73 69 6e 67 20 63 61 rint "Reusing ca
9f10: 63 68 65 64 20 73 74 6d 74 20 66 6f 72 20 22 20 ched stmt for "
9f20: 73 74 6d 74 29 0a 3b 3b 3b 20 09 28 68 61 73 68 stmt).;;; .(hash
9f30: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
9f40: 6c 74 20 63 61 63 68 65 20 73 74 6d 74 20 23 66 lt cache stmt #f
9f50: 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 6c 65 )).;;; (le
9f60: 74 20 28 28 73 74 68 20 28 73 71 6c 69 74 65 33 t ((sth (sqlite3
9f70: 3a 70 72 65 70 61 72 65 20 64 62 20 73 74 6d 74 :prepare db stmt
9f80: 29 29 29 0a 3b 3b 3b 20 09 28 68 61 73 68 2d 74 ))).;;; .(hash-t
9f90: 61 62 6c 65 2d 73 65 74 21 20 63 61 63 68 65 20 able-set! cache
9fa0: 73 74 6d 74 20 73 74 68 29 0a 3b 3b 3b 20 09 3b stmt sth).;;; .;
9fb0: 3b 20 28 70 72 69 6e 74 20 22 70 72 65 70 61 72 ; (print "prepar
9fc0: 65 64 20 73 74 6d 74 20 66 6f 72 20 22 20 73 74 ed stmt for " st
9fd0: 6d 74 29 0a 3b 3b 3b 20 09 73 74 68 29 29 29 0a mt).;;; .sth))).
9fe0: 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 61 20 6c 69 ;;; .;;; ;; a li
9ff0: 74 74 6c 65 20 6d 6f 72 65 20 65 78 70 65 6e 73 ttle more expens
a000: 69 76 65 20 62 75 74 20 64 6f 65 73 20 61 6c 6c ive but does all
a010: 20 74 68 65 20 74 65 64 69 6f 75 73 20 64 65 66 the tedious def
a020: 65 72 65 6e 63 69 6e 67 20 2d 20 6f 6e 6c 79 20 erencing - only
a030: 75 73 65 20 69 66 20 79 6f 75 20 64 6f 6e 27 74 use if you don't
a040: 20 61 6c 72 65 61 64 79 0a 3b 3b 3b 20 3b 3b 20 already.;;; ;;
a050: 68 61 76 65 20 64 62 64 61 74 20 61 6e 64 20 64 have dbdat and d
a060: 62 20 73 69 74 74 69 6e 67 20 61 72 6f 75 6e 64 b sitting around
a070: 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 .;;; ;;.;;; (def
a080: 69 6e 65 20 28 66 75 6c 6c 2d 67 65 74 2d 73 74 ine (full-get-st
a090: 68 20 61 63 66 67 20 66 6e 61 6d 65 20 73 74 6d h acfg fname stm
a0a0: 74 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 t).;;; (let* (
a0b0: 28 64 62 64 61 74 20 20 28 67 65 74 2d 64 62 68 (dbdat (get-dbh
a0c0: 20 61 63 66 67 20 66 6e 61 6d 65 29 29 0a 3b 3b acfg fname)).;;
a0d0: 3b 20 09 20 28 64 62 20 20 20 20 20 28 64 62 64 ; . (db (dbd
a0e0: 61 74 2d 64 62 68 20 64 62 64 61 74 29 29 0a 3b at-dbh dbdat)).;
a0f0: 3b 3b 20 09 20 28 73 74 68 73 20 20 20 28 64 62 ;; . (sths (db
a100: 64 61 74 2d 73 74 68 73 20 64 62 64 61 74 29 29 dat-sths dbdat))
a110: 29 0a 3b 3b 3b 20 20 20 20 20 28 67 65 74 2d 73 ).;;; (get-s
a120: 74 68 20 64 62 20 73 74 68 73 20 73 74 6d 74 29 th db sths stmt)
a130: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 77 )).;;; .;;; ;; w
a140: 72 69 74 65 20 74 6f 20 61 20 64 62 0a 3b 3b 3b rite to a db.;;;
a150: 20 3b 3b 20 61 63 66 67 3a 20 61 72 65 61 20 64 ;; acfg: area d
a160: 61 74 61 0a 3b 3b 3b 20 3b 3b 20 72 64 61 74 3a ata.;;; ;; rdat:
a170: 20 72 65 71 75 65 73 74 20 64 61 74 61 0a 3b 3b request data.;;
a180: 3b 20 3b 3b 20 68 64 61 74 3a 20 28 68 6f 73 74 ; ;; hdat: (host
a190: 20 2e 20 70 6f 72 74 29 0a 3b 3b 3b 20 3b 3b 0a . port).;;; ;;.
a1a0: 3b 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;; ;; (define (
a1b0: 64 62 77 72 69 74 65 20 61 63 66 67 20 72 64 61 dbwrite acfg rda
a1c0: 74 20 68 64 61 74 20 64 61 74 61 2d 69 6e 29 0a t hdat data-in).
a1d0: 3b 3b 3b 20 3b 3b 20 20 20 28 6c 65 74 2a 20 28 ;;; ;; (let* (
a1e0: 28 64 62 6e 61 6d 65 20 28 63 61 72 20 64 61 74 (dbname (car dat
a1f0: 61 2d 69 6e 29 29 0a 3b 3b 3b 20 3b 3b 20 09 20 a-in)).;;; ;; .
a200: 28 64 62 64 61 74 20 20 28 67 65 74 2d 64 62 68 (dbdat (get-dbh
a210: 20 61 63 66 67 20 64 62 6e 61 6d 65 29 29 0a 3b acfg dbname)).;
a220: 3b 3b 20 3b 3b 20 09 20 28 64 62 20 20 20 20 20 ;; ;; . (db
a230: 28 64 62 64 61 74 2d 64 62 68 20 64 62 64 61 74 (dbdat-dbh dbdat
a240: 29 29 0a 3b 3b 3b 20 3b 3b 20 09 20 28 73 74 68 )).;;; ;; . (sth
a250: 73 20 20 20 28 64 62 64 61 74 2d 73 74 68 73 20 s (dbdat-sths
a260: 64 62 64 61 74 29 29 0a 3b 3b 3b 20 3b 3b 20 09 dbdat)).;;; ;; .
a270: 20 28 73 74 6d 74 20 20 20 28 63 61 6c 6c 64 61 (stmt (callda
a280: 74 2d 6f 62 6a 20 72 64 61 74 29 29 0a 3b 3b 3b t-obj rdat)).;;;
a290: 20 3b 3b 20 09 20 28 73 74 68 20 20 20 20 28 67 ;; . (sth (g
a2a0: 65 74 2d 73 74 68 20 64 62 20 73 74 68 73 20 73 et-sth db sths s
a2b0: 74 6d 74 29 29 0a 3b 3b 3b 20 3b 3b 20 09 20 28 tmt)).;;; ;; . (
a2c0: 64 61 74 61 20 20 20 28 63 64 72 20 64 61 74 61 data (cdr data
a2d0: 2d 69 6e 29 29 29 0a 3b 3b 3b 20 3b 3b 20 20 20 -in))).;;; ;;
a2e0: 20 20 28 70 72 69 6e 74 20 22 64 62 6e 61 6d 65 (print "dbname
a2f0: 3a 20 22 20 64 62 6e 61 6d 65 20 22 20 61 63 66 : " dbname " acf
a300: 67 3a 20 22 20 61 63 66 67 20 22 20 72 64 61 74 g: " acfg " rdat
a310: 3a 20 22 20 28 63 61 6c 6c 64 61 74 2d 3e 61 6c : " (calldat->al
a320: 69 73 74 20 72 64 61 74 29 20 22 20 68 64 61 74 ist rdat) " hdat
a330: 3a 20 22 20 68 64 61 74 20 22 20 64 61 74 61 3a : " hdat " data:
a340: 20 22 20 64 61 74 61 29 0a 3b 3b 3b 20 3b 3b 20 " data).;;; ;;
a350: 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 64 61 (print "dbda
a360: 74 3a 20 22 20 28 64 62 64 61 74 2d 3e 61 6c 69 t: " (dbdat->ali
a370: 73 74 20 64 62 64 61 74 29 29 0a 3b 3b 3b 20 3b st dbdat)).;;; ;
a380: 3b 20 20 20 20 20 28 61 70 70 6c 79 20 73 71 6c ; (apply sql
a390: 69 74 65 33 3a 65 78 65 63 75 74 65 20 73 74 68 ite3:execute sth
a3a0: 20 64 61 74 61 29 0a 3b 3b 3b 20 3b 3b 20 20 20 data).;;; ;;
a3b0: 20 20 28 73 61 76 65 2d 64 62 68 20 61 63 66 67 (save-dbh acfg
a3c0: 20 64 62 6e 61 6d 65 20 64 62 64 61 74 29 0a 3b dbname dbdat).;
a3d0: 3b 3b 20 3b 3b 20 20 20 20 20 23 74 0a 3b 3b 3b ;; ;; #t.;;;
a3e0: 20 3b 3b 20 20 20 20 20 29 29 0a 3b 3b 3b 20 0a ;; )).;;; .
a3f0: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 66 69 6e ;;; (define (fin
a400: 61 6c 69 7a 65 2d 61 6c 6c 2d 64 62 2d 68 61 6e alize-all-db-han
a410: 64 6c 65 73 20 61 63 66 67 29 0a 3b 3b 3b 20 20 dles acfg).;;;
a420: 20 28 6c 65 74 2a 20 28 28 64 62 68 61 6e 64 6c (let* ((dbhandl
a430: 65 73 20 28 61 72 65 61 2d 64 62 68 61 6e 64 6c es (area-dbhandl
a440: 65 73 20 61 63 66 67 29 29 20 20 3b 3b 20 64 62 es acfg)) ;; db
a450: 68 61 6e 64 6c 65 73 20 69 73 20 68 61 73 68 20 handles is hash
a460: 6f 66 20 66 6e 61 6d 65 20 3d 3d 3e 20 64 62 64 of fname ==> dbd
a470: 61 74 0a 3b 3b 3b 20 09 20 28 6e 75 6d 20 20 20 at.;;; . (num
a480: 20 20 20 20 30 29 29 0a 3b 3b 3b 20 20 20 20 20 0)).;;;
a490: 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 20 20 (for-each.;;;
a4a0: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 72 65 61 (lambda (area
a4b0: 2d 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 20 20 20 -name).;;;
a4c0: 20 20 28 70 72 69 6e 74 20 22 43 6c 6f 73 69 6e (print "Closin
a4d0: 67 20 68 61 6e 64 6c 65 73 20 66 6f 72 20 22 20 g handles for "
a4e0: 61 72 65 61 2d 6e 61 6d 65 29 0a 3b 3b 3b 20 20 area-name).;;;
a4f0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 62 64 (let ((dbd
a500: 61 74 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ats (hash-table-
a510: 72 65 66 2f 64 65 66 61 75 6c 74 20 64 62 68 61 ref/default dbha
a520: 6e 64 6c 65 73 20 61 72 65 61 2d 6e 61 6d 65 20 ndles area-name
a530: 27 28 29 29 29 29 0a 3b 3b 3b 20 09 20 28 66 6f '()))).;;; . (fo
a540: 72 2d 65 61 63 68 0a 3b 3b 3b 20 09 20 20 28 6c r-each.;;; . (l
a550: 61 6d 62 64 61 20 28 64 62 64 61 74 29 0a 3b 3b ambda (dbdat).;;
a560: 3b 20 09 20 20 20 20 3b 3b 20 66 69 72 73 74 20 ; . ;; first
a570: 63 6c 6f 73 65 20 61 6c 6c 20 73 74 61 74 65 6d close all statem
a580: 65 6e 74 20 68 61 6e 64 6c 65 73 0a 3b 3b 3b 20 ent handles.;;;
a590: 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b . (for-each.;
a5a0: 3b 3b 20 09 20 20 20 20 20 28 6c 61 6d 62 64 61 ;; . (lambda
a5b0: 20 28 73 74 68 29 0a 3b 3b 3b 20 09 20 20 20 20 (sth).;;; .
a5c0: 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 (sqlite3:fina
a5d0: 6c 69 7a 65 21 20 73 74 68 29 0a 3b 3b 3b 20 09 lize! sth).;;; .
a5e0: 20 20 20 20 20 20 20 28 73 65 74 21 20 6e 75 6d (set! num
a5f0: 20 28 2b 20 6e 75 6d 20 31 29 29 29 0a 3b 3b 3b (+ num 1))).;;;
a600: 20 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 . (hash-tab
a610: 6c 65 2d 76 61 6c 75 65 73 20 28 64 62 64 61 74 le-values (dbdat
a620: 2d 73 74 68 73 20 64 62 64 61 74 29 29 29 0a 3b -sths dbdat))).;
a630: 3b 3b 20 09 20 20 20 20 3b 3b 20 6e 6f 77 20 63 ;; . ;; now c
a640: 6c 6f 73 65 20 74 68 65 20 64 62 68 0a 3b 3b 3b lose the dbh.;;;
a650: 20 09 20 20 20 20 28 73 65 74 21 20 6e 75 6d 20 . (set! num
a660: 28 2b 20 6e 75 6d 20 31 29 29 0a 3b 3b 3b 20 09 (+ num 1)).;;; .
a670: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e (sqlite3:fin
a680: 61 6c 69 7a 65 21 20 28 64 62 64 61 74 2d 64 62 alize! (dbdat-db
a690: 68 20 64 62 64 61 74 29 29 29 0a 3b 3b 3b 20 09 h dbdat))).;;; .
a6a0: 20 20 64 62 64 61 74 73 29 29 29 0a 3b 3b 3b 20 dbdats))).;;;
a6b0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
a6c0: 2d 6b 65 79 73 20 64 62 68 61 6e 64 6c 65 73 29 -keys dbhandles)
a6d0: 29 0a 3b 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 ).;;; (print
a6e0: 20 22 46 49 4e 41 4c 49 5a 45 44 20 22 20 6e 75 "FINALIZED " nu
a6f0: 6d 20 22 20 64 62 68 61 6e 64 6c 65 73 22 29 29 m " dbhandles"))
a700: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d ).;;; .;;; ;;===
a710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a750: 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 57 20 4f 20 52 ===.;;; ;; W O R
a760: 20 4b 20 20 20 51 20 55 20 45 20 55 20 45 20 20 K Q U E U E
a770: 20 48 20 41 20 4e 20 44 20 4c 20 49 20 4e 20 47 H A N D L I N G
a780: 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d .;;; ;;========
a790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a7a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a7b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a7c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
a7d0: 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 ;; .;;; (define
a7e0: 28 72 65 67 69 73 74 65 72 2d 64 62 2d 61 73 2d (register-db-as-
a7f0: 6d 69 6e 65 20 61 63 66 67 20 64 62 6e 61 6d 65 mine acfg dbname
a800: 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 28 28 68 ).;;; (let ((h
a810: 74 20 28 61 72 65 61 2d 64 62 73 20 61 63 66 67 t (area-dbs acfg
a820: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 ))).;;; (if
a830: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
a840: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 -ref/default ht
a850: 64 62 6e 61 6d 65 20 23 66 29 29 0a 3b 3b 3b 20 dbname #f)).;;;
a860: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
a870: 21 20 68 74 20 64 62 6e 61 6d 65 20 28 72 61 6e ! ht dbname (ran
a880: 64 6f 6d 20 31 30 30 30 30 29 29 29 29 29 0a 3b dom 10000))))).;
a890: 3b 3b 20 09 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 ;; ..;;; (define
a8a0: 20 28 77 6f 72 6b 2d 71 75 65 75 65 2d 61 64 64 (work-queue-add
a8b0: 20 61 63 66 67 20 66 6e 61 6d 65 20 77 69 74 65 acfg fname wite
a8c0: 6d 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 m).;;; (let* (
a8d0: 28 77 6f 72 6b 2d 71 75 65 75 65 2d 73 74 61 72 (work-queue-star
a8e0: 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 t (current-milli
a8f0: 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 seconds)).;;; .
a900: 28 61 63 74 69 6f 6e 20 20 20 20 20 20 20 20 20 (action
a910: 20 20 28 77 69 74 65 6d 2d 61 63 74 69 6f 6e 20 (witem-action
a920: 77 69 74 65 6d 29 29 20 3b 3b 20 4e 42 20 74 68 witem)) ;; NB th
a930: 65 20 61 63 74 69 6f 6e 20 69 73 20 74 68 65 20 e action is the
a940: 69 6e 64 65 78 20 69 6e 74 6f 20 74 68 65 20 72 index into the r
a950: 64 61 74 20 61 63 74 69 6f 6e 73 0a 3b 3b 3b 20 dat actions.;;;
a960: 09 20 28 71 64 61 74 20 20 20 20 20 20 20 20 20 . (qdat
a970: 20 20 20 20 28 6f 72 20 28 68 61 73 68 2d 74 61 (or (hash-ta
a980: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
a990: 28 61 72 65 61 2d 77 71 75 65 75 65 73 20 61 63 (area-wqueues ac
a9a0: 66 67 29 20 66 6e 61 6d 65 20 23 66 29 0a 3b 3b fg) fname #f).;;
a9b0: 3b 20 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 ; ... (let
a9c0: 20 28 28 6e 65 77 71 64 61 74 20 28 6d 61 6b 65 ((newqdat (make
a9d0: 2d 71 64 61 74 29 29 29 0a 3b 3b 3b 20 09 09 09 -qdat))).;;; ...
a9e0: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
a9f0: 74 21 20 28 61 72 65 61 2d 77 71 75 65 75 65 73 t! (area-wqueues
aa00: 20 61 63 66 67 29 20 66 6e 61 6d 65 20 6e 65 77 acfg) fname new
aa10: 71 64 61 74 29 0a 3b 3b 3b 20 09 09 09 09 20 6e qdat).;;; .... n
aa20: 65 77 71 64 61 74 29 29 29 0a 3b 3b 3b 20 09 20 ewqdat))).;;; .
aa30: 28 72 64 61 74 20 20 20 20 20 20 20 20 20 20 20 (rdat
aa40: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
aa50: 66 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d f/default (area-
aa60: 72 74 61 62 6c 65 20 61 63 66 67 29 20 61 63 74 rtable acfg) act
aa70: 69 6f 6e 20 23 66 29 29 29 0a 3b 3b 3b 20 20 20 ion #f))).;;;
aa80: 20 20 28 69 66 20 72 64 61 74 0a 3b 3b 3b 20 09 (if rdat.;;; .
aa90: 28 71 75 65 75 65 2d 61 64 64 21 0a 3b 3b 3b 20 (queue-add!.;;;
aaa0: 09 20 28 63 61 73 65 20 28 63 61 6c 6c 64 61 74 . (case (calldat
aab0: 2d 63 74 79 70 65 20 72 64 61 74 29 0a 3b 3b 3b -ctype rdat).;;;
aac0: 20 09 20 20 20 28 28 64 62 77 72 69 74 65 29 20 . ((dbwrite)
aad0: 20 20 28 72 65 67 69 73 74 65 72 2d 64 62 2d 61 (register-db-a
aae0: 73 2d 6d 69 6e 65 20 61 63 66 67 20 66 6e 61 6d s-mine acfg fnam
aaf0: 65 29 28 71 64 61 74 2d 77 72 69 74 65 71 20 71 e)(qdat-writeq q
ab00: 64 61 74 29 29 0a 3b 3b 3b 20 09 20 20 20 28 28 dat)).;;; . ((
ab10: 64 62 72 65 61 64 29 20 20 20 20 28 72 65 67 69 dbread) (regi
ab20: 73 74 65 72 2d 64 62 2d 61 73 2d 6d 69 6e 65 20 ster-db-as-mine
ab30: 61 63 66 67 20 66 6e 61 6d 65 29 28 71 64 61 74 acfg fname)(qdat
ab40: 2d 72 65 61 64 71 20 20 71 64 61 74 29 29 0a 3b -readq qdat)).;
ab50: 3b 3b 20 09 20 20 20 28 28 64 62 72 77 29 20 20 ;; . ((dbrw)
ab60: 20 20 20 20 28 72 65 67 69 73 74 65 72 2d 64 62 (register-db
ab70: 2d 61 73 2d 6d 69 6e 65 20 61 63 66 67 20 66 6e -as-mine acfg fn
ab80: 61 6d 65 29 28 71 64 61 74 2d 72 77 71 20 20 20 ame)(qdat-rwq
ab90: 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 20 20 20 qdat)).;;; .
aba0: 28 28 6f 73 6c 6f 6e 67 29 20 20 20 20 28 71 64 ((oslong) (qd
abb0: 61 74 2d 6f 73 6c 6f 6e 67 20 71 64 61 74 29 29 at-oslong qdat))
abc0: 0a 3b 3b 3b 20 09 20 20 20 28 28 6f 73 73 68 6f .;;; . ((ossho
abd0: 72 74 29 20 20 20 28 71 64 61 74 2d 6f 73 73 68 rt) (qdat-ossh
abe0: 6f 72 74 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 ort qdat)).;;; .
abf0: 20 20 20 28 28 66 75 6c 6c 2d 70 69 6e 67 29 20 ((full-ping)
ac00: 28 71 64 61 74 2d 6d 69 73 63 20 20 71 64 61 74 (qdat-misc qdat
ac10: 29 29 0a 3b 3b 3b 20 09 20 20 20 28 65 6c 73 65 )).;;; . (else
ac20: 0a 3b 3b 3b 20 09 20 20 20 20 28 70 72 69 6e 74 .;;; . (print
ac30: 20 22 45 52 52 4f 52 3a 20 6e 6f 20 71 75 65 75 "ERROR: no queu
ac40: 65 20 66 6f 72 20 22 20 61 63 74 69 6f 6e 20 22 e for " action "
ac50: 2e 20 41 64 64 69 6e 67 20 74 6f 20 64 62 77 72 . Adding to dbwr
ac60: 69 74 65 20 71 75 65 75 65 2e 22 29 0a 3b 3b 3b ite queue.").;;;
ac70: 20 09 20 20 20 20 28 71 64 61 74 2d 77 72 69 74 . (qdat-writ
ac80: 65 71 20 71 64 61 74 29 29 29 0a 3b 3b 3b 20 09 eq qdat))).;;; .
ac90: 20 77 69 74 65 6d 29 0a 3b 3b 3b 20 09 28 63 61 witem).;;; .(ca
aca0: 73 65 20 61 63 74 69 6f 6e 0a 3b 3b 3b 20 09 20 se action.;;; .
acb0: 20 28 28 66 75 6c 6c 2d 70 69 6e 67 29 28 71 64 ((full-ping)(qd
acc0: 61 74 2d 6d 69 73 63 20 71 64 61 74 29 29 0a 3b at-misc qdat)).;
acd0: 3b 3b 20 09 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 ;; . (else.;;;
ace0: 09 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f . (print "ERRO
acf0: 52 3a 20 4e 6f 20 61 63 74 69 6f 6e 20 22 20 61 R: No action " a
ad00: 63 74 69 6f 6e 20 22 20 77 61 73 20 72 65 67 69 ction " was regi
ad10: 73 74 65 72 65 64 22 29 29 29 29 0a 3b 3b 3b 20 stered")))).;;;
ad20: 20 20 20 20 28 73 64 62 67 3e 20 22 77 6f 72 6b (sdbg> "work
ad30: 2d 71 75 65 75 65 2d 61 64 64 22 20 22 71 75 65 -queue-add" "que
ad40: 75 65 2d 61 64 64 22 20 77 6f 72 6b 2d 71 75 65 ue-add" work-que
ad50: 75 65 2d 73 74 61 72 74 20 23 66 20 23 66 29 0a ue-start #f #f).
ad60: 3b 3b 3b 20 20 20 20 20 23 74 29 29 20 3b 3b 20 ;;; #t)) ;;
ad70: 66 6f 72 20 6e 6f 77 2c 20 73 69 6d 70 6c 79 20 for now, simply
ad80: 72 65 74 75 72 6e 20 23 74 20 74 6f 20 69 6e 64 return #t to ind
ad90: 69 63 61 74 65 20 72 65 71 75 65 73 74 20 67 6f icate request go
ada0: 74 20 74 6f 20 74 68 65 20 71 75 65 75 65 0a 3b t to the queue.;
adb0: 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 ;; .;;; (define
adc0: 28 64 6f 71 75 65 75 65 20 61 63 66 67 20 71 20 (doqueue acfg q
add0: 66 6e 61 6d 65 20 64 62 64 61 74 20 64 62 68 29 fname dbdat dbh)
ade0: 0a 3b 3b 3b 20 20 20 3b 3b 20 28 70 72 69 6e 74 .;;; ;; (print
adf0: 20 22 64 6f 71 75 65 75 65 3a 20 22 20 66 6e 61 "doqueue: " fna
ae00: 6d 65 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 me).;;; (let*
ae10: 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 ((start-time (cu
ae20: 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
ae30: 64 73 29 29 0a 3b 3b 3b 20 09 20 28 71 6c 65 6e ds)).;;; . (qlen
ae40: 20 20 20 20 20 20 20 28 71 75 65 75 65 2d 6c 65 (queue-le
ae50: 6e 67 74 68 20 71 29 29 29 0a 3b 3b 3b 20 20 20 ngth q))).;;;
ae60: 20 20 28 69 66 20 28 3e 20 71 6c 65 6e 20 31 29 (if (> qlen 1)
ae70: 0a 3b 3b 3b 20 09 28 70 72 69 6e 74 20 22 50 72 .;;; .(print "Pr
ae80: 6f 63 65 73 73 69 6e 67 20 71 75 65 75 65 20 6f ocessing queue o
ae90: 66 20 6c 65 6e 67 74 68 20 22 20 71 6c 65 6e 29 f length " qlen)
aea0: 29 0a 3b 3b 3b 20 20 20 20 20 28 6c 65 74 20 6c ).;;; (let l
aeb0: 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 20 20 20 oop ((count
aec0: 20 30 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 0).;;; .
aed0: 28 72 65 73 70 6f 6e 73 65 73 20 27 28 29 29 29 (responses '()))
aee0: 0a 3b 3b 3b 20 20 20 20 20 20 20 28 6c 65 74 20 .;;; (let
aef0: 28 28 64 65 6c 74 61 20 28 2d 20 28 63 75 72 72 ((delta (- (curr
af00: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
af10: 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 29 0a ) start-time))).
af20: 3b 3b 3b 20 09 28 69 66 20 28 6f 72 20 28 71 75 ;;; .(if (or (qu
af30: 65 75 65 2d 65 6d 70 74 79 3f 20 71 29 0a 3b 3b eue-empty? q).;;
af40: 3b 20 09 09 28 3e 20 64 65 6c 74 61 20 34 30 30 ; ..(> delta 400
af50: 29 29 20 3b 3b 20 73 74 6f 70 20 77 6f 72 6b 69 )) ;; stop worki
af60: 6e 67 20 6f 6e 20 74 68 69 73 20 71 75 65 75 65 ng on this queue
af70: 20 61 66 74 65 72 20 34 30 30 6d 73 20 68 61 76 after 400ms hav
af80: 65 20 70 61 73 73 65 64 0a 3b 3b 3b 20 09 20 20 e passed.;;; .
af90: 20 20 28 6c 69 73 74 20 63 6f 75 6e 74 20 64 65 (list count de
afa0: 6c 74 61 20 72 65 73 70 6f 6e 73 65 73 29 20 3b lta responses) ;
afb0: 3b 20 72 65 74 75 72 6e 20 63 6f 75 6e 74 2c 20 ; return count,
afc0: 64 65 6c 74 61 20 61 6e 64 20 72 65 73 70 6f 6e delta and respon
afd0: 73 65 73 20 6c 69 73 74 0a 3b 3b 3b 20 09 20 20 ses list.;;; .
afe0: 20 20 28 6c 65 74 2a 20 28 28 77 69 74 65 6d 20 (let* ((witem
aff0: 20 28 71 75 65 75 65 2d 72 65 6d 6f 76 65 21 20 (queue-remove!
b000: 71 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 61 63 q)).;;; .. (ac
b010: 74 69 6f 6e 20 28 77 69 74 65 6d 2d 61 63 74 69 tion (witem-acti
b020: 6f 6e 20 77 69 74 65 6d 29 29 0a 3b 3b 3b 20 09 on witem)).;;; .
b030: 09 20 20 20 28 72 64 61 74 20 20 20 28 77 69 74 . (rdat (wit
b040: 65 6d 2d 72 64 61 74 20 20 20 77 69 74 65 6d 29 em-rdat witem)
b050: 29 0a 3b 3b 3b 20 09 09 20 20 20 28 73 74 6d 74 ).;;; .. (stmt
b060: 20 20 20 28 63 61 6c 6c 64 61 74 2d 6f 62 6a 20 (calldat-obj
b070: 72 64 61 74 29 29 0a 3b 3b 3b 20 09 09 20 20 20 rdat)).;;; ..
b080: 28 73 74 68 20 20 20 20 28 66 75 6c 6c 2d 67 65 (sth (full-ge
b090: 74 2d 73 74 68 20 61 63 66 67 20 66 6e 61 6d 65 t-sth acfg fname
b0a0: 20 73 74 6d 74 29 29 0a 3b 3b 3b 20 09 09 20 20 stmt)).;;; ..
b0b0: 20 28 63 74 79 70 65 20 20 28 63 61 6c 6c 64 61 (ctype (callda
b0c0: 74 2d 63 74 79 70 65 20 72 64 61 74 29 29 0a 3b t-ctype rdat)).;
b0d0: 3b 3b 20 09 09 20 20 20 28 64 61 74 61 20 20 20 ;; .. (data
b0e0: 28 77 69 74 65 6d 2d 64 61 74 61 20 20 20 77 69 (witem-data wi
b0f0: 74 65 6d 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 tem)).;;; .. (
b100: 63 6f 6f 6b 69 65 20 28 77 69 74 65 6d 2d 63 6f cookie (witem-co
b110: 6f 6b 69 65 20 77 69 74 65 6d 29 29 29 0a 3b 3b okie witem))).;;
b120: 3b 20 09 20 20 20 20 20 20 3b 3b 20 64 6f 20 74 ; . ;; do t
b130: 68 65 20 70 72 6f 63 65 73 73 69 6e 67 20 61 6e he processing an
b140: 64 20 73 61 76 65 20 74 68 65 20 72 65 73 75 6c d save the resul
b150: 74 20 69 6e 20 77 69 74 65 6d 2d 72 65 73 75 6c t in witem-resul
b160: 74 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 77 69 t.;;; . (wi
b170: 74 65 6d 2d 72 65 73 75 6c 74 2d 73 65 74 21 0a tem-result-set!.
b180: 3b 3b 3b 20 09 20 20 20 20 20 20 20 77 69 74 65 ;;; . wite
b190: 6d 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 63 m.;;; . (c
b1a0: 61 73 65 20 63 74 79 70 65 20 3b 3b 20 61 63 74 ase ctype ;; act
b1b0: 69 6f 6e 0a 3b 3b 3b 20 09 09 20 28 28 6e 6f 62 ion.;;; .. ((nob
b1c0: 6c 6f 63 6b 77 72 69 74 65 29 20 3b 3b 20 62 6c lockwrite) ;; bl
b1d0: 69 6e 64 20 77 72 69 74 65 2c 20 6e 6f 20 61 63 ind write, no ac
b1e0: 6b 20 6f 66 20 73 75 63 63 65 73 73 20 72 65 74 k of success ret
b1f0: 75 72 6e 65 64 0a 3b 3b 3b 20 09 09 20 20 28 61 urned.;;; .. (a
b200: 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 pply sqlite3:exe
b210: 63 75 74 65 20 73 74 68 20 64 61 74 61 29 0a 3b cute sth data).;
b220: 3b 3b 20 09 09 20 20 28 73 71 6c 69 74 65 33 3a ;; .. (sqlite3:
b230: 6c 61 73 74 2d 69 6e 73 65 72 74 2d 72 6f 77 69 last-insert-rowi
b240: 64 20 64 62 68 29 29 0a 3b 3b 3b 20 09 09 20 28 d dbh)).;;; .. (
b250: 28 64 62 77 72 69 74 65 29 20 20 20 20 20 20 3b (dbwrite) ;
b260: 3b 20 62 6c 6f 63 6b 69 6e 67 20 77 72 69 74 65 ; blocking write
b270: 20 20 20 0a 3b 3b 3b 20 09 09 20 20 28 61 70 70 .;;; .. (app
b280: 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 75 ly sqlite3:execu
b290: 74 65 20 73 74 68 20 64 61 74 61 29 0a 3b 3b 3b te sth data).;;;
b2a0: 20 09 09 20 20 23 74 29 0a 3b 3b 3b 20 09 09 20 .. #t).;;; ..
b2b0: 28 28 64 62 72 65 61 64 29 20 3b 3b 20 54 4f 44 ((dbread) ;; TOD
b2c0: 4f 3a 20 63 6f 6e 73 69 64 65 72 20 62 72 65 61 O: consider brea
b2d0: 6b 69 6e 67 20 74 68 69 73 20 75 70 20 61 6e 64 king this up and
b2e0: 20 73 68 69 70 70 69 6e 67 20 69 6e 20 70 69 65 shipping in pie
b2f0: 63 65 73 20 66 6f 72 20 6c 61 72 67 65 20 71 75 ces for large qu
b300: 65 72 79 0a 3b 3b 3b 20 09 09 20 20 28 61 70 70 ery.;;; .. (app
b310: 6c 79 20 73 71 6c 69 74 65 33 3a 6d 61 70 2d 72 ly sqlite3:map-r
b320: 6f 77 20 28 6c 61 6d 62 64 61 20 78 20 78 29 20 ow (lambda x x)
b330: 73 74 68 20 64 61 74 61 29 29 0a 3b 3b 3b 20 09 sth data)).;;; .
b340: 09 20 28 28 66 75 6c 6c 2d 70 69 6e 67 29 20 20 . ((full-ping)
b350: 27 66 75 6c 6c 2d 70 69 6e 67 29 0a 3b 3b 3b 20 'full-ping).;;;
b360: 09 09 20 28 65 6c 73 65 20 28 70 72 69 6e 74 20 .. (else (print
b370: 22 4e 6f 74 20 72 65 61 64 79 20 66 6f 72 20 61 "Not ready for a
b380: 63 74 69 6f 6e 20 22 20 61 63 74 69 6f 6e 29 20 ction " action)
b390: 23 66 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 #f))).;;; .
b3a0: 20 28 6c 6f 6f 70 20 28 61 64 64 31 20 63 6f 75 (loop (add1 cou
b3b0: 6e 74 29 0a 3b 3b 3b 20 09 09 20 20 20 20 28 69 nt).;;; .. (i
b3c0: 66 20 63 6f 6f 6b 69 65 0a 3b 3b 3b 20 09 09 09 f cookie.;;; ...
b3d0: 28 63 6f 6e 73 20 77 69 74 65 6d 20 72 65 73 70 (cons witem resp
b3e0: 6f 6e 73 65 73 29 0a 3b 3b 3b 20 09 09 09 72 65 onses).;;; ...re
b3f0: 73 70 6f 6e 73 65 73 29 29 29 29 29 29 29 29 0a sponses)))))))).
b400: 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 64 6f 20 75 ;;; .;;; ;; do u
b410: 70 20 74 6f 20 34 30 30 6d 73 20 6f 66 20 70 72 p to 400ms of pr
b420: 6f 63 65 73 73 69 6e 67 20 6f 6e 20 65 61 63 68 ocessing on each
b430: 20 71 75 65 75 65 0a 3b 3b 3b 20 3b 3b 20 2d 20 queue.;;; ;; -
b440: 74 68 65 20 77 6f 72 6b 2d 71 75 65 75 65 2d 70 the work-queue-p
b450: 72 6f 63 65 73 73 6f 72 20 77 69 6c 6c 20 61 6c rocessor will al
b460: 6c 6f 77 20 74 68 65 20 6d 61 78 20 31 32 30 30 low the max 1200
b470: 6d 73 20 6f 66 20 77 6f 72 6b 20 74 6f 20 63 6f ms of work to co
b480: 6d 70 6c 65 74 65 20 62 75 74 20 69 74 20 77 69 mplete but it wi
b490: 6c 6c 20 66 6c 61 67 20 61 73 20 6f 76 65 72 6c ll flag as overl
b4a0: 6f 61 64 65 64 0a 3b 3b 3b 20 3b 3b 20 0a 3b 3b oaded.;;; ;; .;;
b4b0: 3b 20 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 ; (define (proce
b4c0: 73 73 2d 64 62 2d 71 75 65 72 69 65 73 20 61 63 ss-db-queries ac
b4d0: 66 67 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 fg fname).;;;
b4e0: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (if (hash-table-
b4f0: 65 78 69 73 74 73 3f 20 28 61 72 65 61 2d 77 71 exists? (area-wq
b500: 75 65 75 65 73 20 61 63 66 67 29 20 66 6e 61 6d ueues acfg) fnam
b510: 65 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 6c 65 e).;;; (le
b520: 74 2a 20 28 28 70 72 6f 63 65 73 73 2d 64 62 2d t* ((process-db-
b530: 71 75 65 72 69 65 73 2d 73 74 61 72 74 2d 74 69 queries-start-ti
b540: 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c me (current-mill
b550: 69 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 iseconds)).;;; .
b560: 20 20 20 20 20 28 71 64 61 74 20 20 20 20 20 20 (qdat
b570: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
b580: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
b590: 61 72 65 61 2d 77 71 75 65 75 65 73 20 61 63 66 area-wqueues acf
b5a0: 67 29 20 66 6e 61 6d 65 20 23 66 29 29 0a 3b 3b g) fname #f)).;;
b5b0: 3b 20 09 20 20 20 20 20 28 71 75 65 75 65 2d 73 ; . (queue-s
b5c0: 79 6d 2d 3e 71 75 65 75 65 20 28 6c 61 6d 62 64 ym->queue (lambd
b5d0: 61 20 28 71 75 65 75 65 2d 73 79 6d 29 0a 3b 3b a (queue-sym).;;
b5e0: 3b 20 09 09 09 09 20 28 63 61 73 65 20 71 75 65 ; .... (case que
b5f0: 75 65 2d 73 79 6d 20 20 3b 3b 20 6c 6f 6f 6b 75 ue-sym ;; looku
b600: 70 20 74 68 65 20 71 75 65 75 65 20 66 72 6f 6d p the queue from
b610: 20 71 64 61 74 20 67 69 76 65 6e 20 61 20 6e 61 qdat given a na
b620: 6d 65 20 28 73 79 6d 62 6f 6c 29 0a 3b 3b 3b 20 me (symbol).;;;
b630: 09 09 09 09 20 20 20 28 28 77 71 75 65 75 65 29 .... ((wqueue)
b640: 20 20 28 71 64 61 74 2d 77 72 69 74 65 71 20 71 (qdat-writeq q
b650: 64 61 74 29 29 0a 3b 3b 3b 20 09 09 09 09 20 20 dat)).;;; ....
b660: 20 28 28 72 71 75 65 75 65 29 20 20 28 71 64 61 ((rqueue) (qda
b670: 74 2d 72 65 61 64 71 20 20 71 64 61 74 29 29 0a t-readq qdat)).
b680: 3b 3b 3b 20 09 09 09 09 20 20 20 28 28 72 77 71 ;;; .... ((rwq
b690: 75 65 75 65 29 20 28 71 64 61 74 2d 72 77 71 20 ueue) (qdat-rwq
b6a0: 20 20 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 09 qdat)).;;; ..
b6b0: 09 09 20 20 20 28 28 6d 69 73 63 29 20 20 20 20 .. ((misc)
b6c0: 28 71 64 61 74 2d 6d 69 73 63 20 20 20 71 64 61 (qdat-misc qda
b6d0: 74 29 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 28 t)).;;; .... (
b6e0: 65 6c 73 65 20 23 66 29 29 29 29 0a 3b 3b 3b 20 else #f)))).;;;
b6f0: 09 20 20 20 20 20 28 64 62 64 61 74 20 20 20 28 . (dbdat (
b700: 67 65 74 2d 64 62 68 20 61 63 66 67 20 66 6e 61 get-dbh acfg fna
b710: 6d 65 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 28 me)).;;; . (
b720: 64 62 68 20 20 20 20 20 28 69 66 20 28 64 62 64 dbh (if (dbd
b730: 61 74 3f 20 64 62 64 61 74 29 28 64 62 64 61 74 at? dbdat)(dbdat
b740: 2d 64 62 68 20 64 62 64 61 74 29 20 23 66 29 29 -dbh dbdat) #f))
b750: 0a 3b 3b 3b 20 09 20 20 20 20 20 28 6e 6f 77 74 .;;; . (nowt
b760: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
b770: 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 09 3b 3b 20 onds))).;;; .;;
b780: 68 61 6e 64 6c 65 20 74 68 65 20 71 75 65 75 65 handle the queue
b790: 73 20 74 68 61 74 20 72 65 71 75 69 72 65 20 61 s that require a
b7a0: 20 74 72 61 6e 73 61 63 74 69 6f 6e 0a 3b 3b 3b transaction.;;;
b7b0: 20 09 3b 3b 0a 3b 3b 3b 20 09 28 6d 61 70 20 3b .;;.;;; .(map ;
b7c0: 3b 20 0a 3b 3b 3b 20 09 20 28 6c 61 6d 62 64 61 ; .;;; . (lambda
b7d0: 20 28 71 75 65 75 65 2d 73 79 6d 29 0a 3b 3b 3b (queue-sym).;;;
b7e0: 20 09 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 . ;; (print "
b7f0: 70 72 6f 63 65 73 73 69 6e 67 20 71 75 65 75 65 processing queue
b800: 20 22 20 71 75 65 75 65 2d 73 79 6d 29 0a 3b 3b " queue-sym).;;
b810: 3b 20 09 20 20 20 28 6c 65 74 2a 20 28 28 71 75 ; . (let* ((qu
b820: 65 75 65 20 28 71 75 65 75 65 2d 73 79 6d 2d 3e eue (queue-sym->
b830: 71 75 65 75 65 20 71 75 65 75 65 2d 73 79 6d 29 queue queue-sym)
b840: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 28 69 66 )).;;; . (if
b850: 20 28 6e 6f 74 20 28 71 75 65 75 65 2d 65 6d 70 (not (queue-emp
b860: 74 79 3f 20 71 75 65 75 65 29 29 0a 3b 3b 3b 20 ty? queue)).;;;
b870: 09 09 20 28 6c 65 74 20 28 28 72 65 73 70 6f 6e .. (let ((respon
b880: 73 65 73 0a 3b 3b 3b 20 09 09 09 28 73 71 6c 69 ses.;;; ...(sqli
b890: 74 65 33 3a 77 69 74 68 2d 74 72 61 6e 73 61 63 te3:with-transac
b8a0: 74 69 6f 6e 20 3b 3b 20 74 6f 64 6f 20 2d 20 63 tion ;; todo - c
b8b0: 61 74 63 68 20 65 78 63 65 70 74 69 6f 6e 73 2e atch exceptions.
b8c0: 2e 2e 0a 3b 3b 3b 20 09 09 09 20 64 62 68 0a 3b ...;;; ... dbh.;
b8d0: 3b 3b 20 09 09 09 20 28 6c 61 6d 62 64 61 20 28 ;; ... (lambda (
b8e0: 29 0a 3b 3b 3b 20 09 09 09 20 20 20 28 6c 65 74 ).;;; ... (let
b8f0: 2a 20 28 28 72 65 73 20 28 64 6f 71 75 65 75 65 * ((res (doqueue
b900: 20 61 63 66 67 20 71 75 65 75 65 20 66 6e 61 6d acfg queue fnam
b910: 65 20 64 62 64 61 74 20 64 62 68 29 29 29 20 3b e dbdat dbh))) ;
b920: 3b 20 74 68 69 73 20 64 6f 65 73 20 74 68 65 20 ; this does the
b930: 77 6f 72 6b 21 0a 3b 3b 3b 20 09 09 09 20 20 20 work!.;;; ...
b940: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 65 73 ;; (print "res
b950: 3d 22 20 72 65 73 29 0a 3b 3b 3b 20 09 09 09 20 =" res).;;; ...
b960: 20 20 20 20 28 6d 61 74 63 68 20 72 65 73 0a 3b (match res.;
b970: 3b 3b 20 09 09 09 20 20 20 20 20 20 28 28 63 6f ;; ... ((co
b980: 75 6e 74 20 64 65 6c 74 61 20 72 65 73 70 6f 6e unt delta respon
b990: 73 65 73 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 ses).;;; ...
b9a0: 20 20 20 28 75 70 64 61 74 65 2d 73 74 61 74 73 (update-stats
b9b0: 20 61 63 66 67 20 66 6e 61 6d 65 20 71 75 65 75 acfg fname queu
b9c0: 65 2d 73 79 6d 20 64 65 6c 74 61 20 63 6f 75 6e e-sym delta coun
b9d0: 74 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 t).;;; ...
b9e0: 20 28 73 64 62 67 3e 20 22 70 72 6f 63 65 73 73 (sdbg> "process
b9f0: 2d 64 62 2d 71 75 65 72 69 65 73 22 20 22 73 71 -db-queries" "sq
ba00: 6c 69 74 65 33 2d 74 72 61 6e 73 61 63 74 69 6f lite3-transactio
ba10: 6e 22 20 70 72 6f 63 65 73 73 2d 64 62 2d 71 75 n" process-db-qu
ba20: 65 72 69 65 73 2d 73 74 61 72 74 2d 74 69 6d 65 eries-start-time
ba30: 20 23 66 20 23 66 29 0a 3b 3b 3b 20 09 09 09 20 #f #f).;;; ...
ba40: 20 20 20 20 20 20 72 65 73 70 6f 6e 73 65 73 29 responses)
ba50: 20 3b 3b 20 72 65 74 75 72 6e 20 72 65 73 70 6f ;; return respo
ba60: 6e 73 65 73 0a 3b 3b 3b 20 09 09 09 20 20 20 20 nses.;;; ...
ba70: 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 09 09 20 (else.;;; ...
ba80: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 (print "ER
ba90: 52 4f 52 3a 20 62 61 64 20 72 65 74 75 72 6e 20 ROR: bad return
baa0: 64 61 74 61 20 66 72 6f 6d 20 64 6f 71 75 65 75 data from doqueu
bab0: 65 20 22 20 72 65 73 29 29 29 0a 3b 3b 3b 20 09 e " res))).;;; .
bac0: 09 09 20 20 20 20 20 29 29 29 29 29 0a 3b 3b 3b .. ))))).;;;
bad0: 20 09 09 20 20 20 3b 3b 20 68 61 76 69 6e 67 20 .. ;; having
bae0: 63 6f 6d 70 6c 65 74 65 64 20 74 68 65 20 74 72 completed the tr
baf0: 61 6e 73 61 63 74 69 6f 6e 2c 20 73 65 6e 64 20 ansaction, send
bb00: 74 68 65 20 72 65 73 70 6f 6e 73 65 73 2e 0a 3b the responses..;
bb10: 3b 3b 20 09 09 20 20 20 3b 3b 20 28 70 72 69 6e ;; .. ;; (prin
bb20: 74 20 22 49 4e 46 4f 3a 20 73 65 6e 64 69 6e 67 t "INFO: sending
bb30: 20 22 20 28 6c 65 6e 67 74 68 20 72 65 73 70 6f " (length respo
bb40: 6e 73 65 73 29 20 22 20 72 65 73 70 6f 6e 73 65 nses) " response
bb50: 73 2e 22 29 0a 3b 3b 3b 20 09 09 20 20 20 28 6c s.").;;; .. (l
bb60: 65 74 20 6c 6f 6f 70 20 28 28 72 65 73 70 6f 6e et loop ((respon
bb70: 73 65 73 2d 6c 65 66 74 20 72 65 73 70 6f 6e 73 ses-left respons
bb80: 65 73 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 es)).;;; ..
bb90: 28 63 6f 6e 64 0a 3b 3b 3b 20 09 09 20 20 20 20 (cond.;;; ..
bba0: 20 20 28 28 6e 75 6c 6c 3f 20 72 65 73 70 6f 6e ((null? respon
bbb0: 73 65 73 2d 6c 65 66 74 29 20 20 23 74 29 0a 3b ses-left) #t).;
bbc0: 3b 3b 20 09 09 20 20 20 20 20 20 28 65 6c 73 65 ;; .. (else
bbd0: 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 28 6c .;;; .. (l
bbe0: 65 74 2a 20 28 28 77 69 74 65 6d 20 20 20 20 28 et* ((witem (
bbf0: 63 61 72 20 72 65 73 70 6f 6e 73 65 73 2d 6c 65 car responses-le
bc00: 66 74 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 ft)).;;; ...
bc10: 20 20 28 72 65 73 70 6f 6e 73 65 20 28 63 64 72 (response (cdr
bc20: 20 72 65 73 70 6f 6e 73 65 73 2d 6c 65 66 74 29 responses-left)
bc30: 29 29 20 20 0a 3b 3b 3b 20 09 09 09 20 28 63 61 )) .;;; ... (ca
bc40: 6c 6c 2d 64 65 6c 69 76 65 72 2d 72 65 73 70 6f ll-deliver-respo
bc50: 6e 73 65 20 61 63 66 67 20 28 77 69 74 65 6d 2d nse acfg (witem-
bc60: 72 69 70 61 64 64 72 20 77 69 74 65 6d 29 28 77 ripaddr witem)(w
bc70: 69 74 65 6d 2d 72 70 6f 72 74 20 77 69 74 65 6d item-rport witem
bc80: 29 0a 3b 3b 3b 20 09 09 09 09 09 09 28 77 69 74 ).;;; ......(wit
bc90: 65 6d 2d 63 6f 6f 6b 69 65 20 77 69 74 65 6d 29 em-cookie witem)
bca0: 28 77 69 74 65 6d 2d 72 65 73 75 6c 74 20 77 69 (witem-result wi
bcb0: 74 65 6d 29 29 29 0a 3b 3b 3b 20 09 09 20 20 20 tem))).;;; ..
bcc0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 64 72 20 72 (loop (cdr r
bcd0: 65 73 70 6f 6e 73 65 73 2d 6c 65 66 74 29 29 29 esponses-left)))
bce0: 29 29 29 0a 3b 3b 3b 20 09 09 20 29 29 29 0a 3b ))).;;; .. ))).;
bcf0: 3b 3b 20 09 20 27 28 77 71 75 65 75 65 20 72 77 ;; . '(wqueue rw
bd00: 71 75 65 75 65 20 72 71 75 65 75 65 29 29 0a 3b queue rqueue)).;
bd10: 3b 3b 20 09 0a 3b 3b 3b 20 09 3b 3b 20 68 61 6e ;; ..;;; .;; han
bd20: 64 6c 65 20 6d 69 73 63 20 71 75 65 75 65 0a 3b dle misc queue.;
bd30: 3b 3b 20 09 3b 3b 0a 3b 3b 3b 20 09 3b 3b 20 28 ;; .;;.;;; .;; (
bd40: 70 72 69 6e 74 20 22 70 72 6f 63 65 73 73 69 6e print "processin
bd50: 67 20 6d 69 73 63 20 71 75 65 75 65 22 29 0a 3b g misc queue").;
bd60: 3b 3b 20 09 28 6c 65 74 20 28 28 71 75 65 75 65 ;; .(let ((queue
bd70: 20 28 71 75 65 75 65 2d 73 79 6d 2d 3e 71 75 65 (queue-sym->que
bd80: 75 65 20 27 6d 69 73 63 29 29 29 0a 3b 3b 3b 20 ue 'misc))).;;;
bd90: 09 20 20 28 64 6f 71 75 65 75 65 20 61 63 66 67 . (doqueue acfg
bda0: 20 71 75 65 75 65 20 66 6e 61 6d 65 20 64 62 64 queue fname dbd
bdb0: 61 74 20 64 62 68 29 29 0a 3b 3b 3b 20 09 3b 3b at dbh)).;;; .;;
bdc0: 20 2e 2e 2e 2e 0a 3b 3b 3b 20 09 28 73 61 76 65 .....;;; .(save
bdd0: 2d 64 62 68 20 61 63 66 67 20 66 6e 61 6d 65 20 -dbh acfg fname
bde0: 64 62 64 61 74 29 0a 3b 3b 3b 20 09 23 74 20 3b dbdat).;;; .#t ;
bdf0: 3b 20 6a 75 73 74 20 74 6f 20 6c 65 74 20 74 68 ; just to let th
be00: 65 20 74 65 73 74 73 20 6b 6e 6f 77 20 77 65 20 e tests know we
be10: 67 6f 74 20 68 65 72 65 0a 3b 3b 3b 20 09 29 0a got here.;;; .).
be20: 3b 3b 3b 20 20 20 20 20 20 20 23 66 20 3b 3b 20 ;;; #f ;;
be30: 6e 6f 74 68 69 6e 67 20 70 72 6f 63 65 73 73 65 nothing processe
be40: 64 0a 3b 3b 3b 20 20 20 20 20 20 20 29 29 0a 3b d.;;; )).;
be50: 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 72 75 6e 20 61 ;; .;;; ;; run a
be60: 6c 6c 20 71 75 65 75 65 73 20 69 6e 20 70 61 72 ll queues in par
be70: 61 6c 6c 65 6c 20 70 65 72 20 64 62 20 62 75 74 allel per db but
be80: 20 73 65 71 75 65 6e 74 69 61 6c 6c 79 20 70 65 sequentially pe
be90: 72 20 71 75 65 75 65 20 66 6f 72 20 74 68 61 74 r queue for that
bea0: 20 64 62 2e 0a 3b 3b 3b 20 3b 3b 20 20 2d 20 70 db..;;; ;; - p
beb0: 72 6f 63 65 73 73 20 74 68 65 20 71 75 65 75 65 rocess the queue
bec0: 73 20 65 76 65 72 79 20 35 30 30 20 6f 72 20 73 s every 500 or s
bed0: 6f 20 6d 73 0a 3b 3b 3b 20 3b 3b 20 20 2d 20 61 o ms.;;; ;; - a
bee0: 6c 6c 6f 77 20 66 6f 72 20 6c 6f 6e 67 20 72 75 llow for long ru
bef0: 6e 6e 69 6e 67 20 71 75 65 72 69 65 73 20 74 6f nning queries to
bf00: 20 63 6f 6e 74 69 6e 75 65 20 62 75 74 20 61 6c continue but al
bf10: 6c 20 6f 74 68 65 72 20 61 63 74 69 76 69 74 69 l other activiti
bf20: 65 73 20 66 6f 72 20 74 68 61 74 0a 3b 3b 3b 20 es for that.;;;
bf30: 3b 3b 20 20 20 20 64 62 20 77 69 6c 6c 20 62 65 ;; db will be
bf40: 20 62 6c 6f 63 6b 65 64 2e 0a 3b 3b 3b 20 3b 3b blocked..;;; ;;
bf50: 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 77 6f .;;; (define (wo
bf60: 72 6b 2d 71 75 65 75 65 2d 70 72 6f 63 65 73 73 rk-queue-process
bf70: 6f 72 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 28 or acfg).;;; (
bf80: 6c 65 74 2a 20 28 28 74 68 72 65 61 64 73 20 28 let* ((threads (
bf90: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
bfa0: 29 29 20 3b 3b 20 66 6e 61 6d 65 20 3d 3e 20 74 )) ;; fname => t
bfb0: 68 72 65 61 64 0a 3b 3b 3b 20 20 20 20 20 28 6c hread.;;; (l
bfc0: 65 74 20 6c 6f 6f 70 20 28 28 66 6e 61 6d 65 73 et loop ((fnames
bfd0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
bfe0: 65 2d 6b 65 79 73 20 28 61 72 65 61 2d 77 71 75 e-keys (area-wqu
bff0: 65 75 65 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b eues acfg))).;;;
c000: 20 09 20 20 20 20 20 20 20 28 74 61 72 67 65 74 . (target
c010: 2d 74 69 6d 65 20 28 2b 20 28 63 75 72 72 65 6e -time (+ (curren
c020: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 t-milliseconds)
c030: 35 30 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 50))).;;;
c040: 3b 3b 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c ;;(if (not (null
c050: 3f 20 66 6e 61 6d 65 73 29 29 28 70 72 69 6e 74 ? fnames))(print
c060: 20 22 50 72 6f 63 65 73 73 69 6e 67 20 66 6f 72 "Processing for
c070: 20 74 68 65 73 65 20 64 61 74 61 62 61 73 65 73 these databases
c080: 3a 20 22 20 66 6e 61 6d 65 73 29 29 0a 3b 3b 3b : " fnames)).;;;
c090: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
c0a0: 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 6c 61 6d .;;; (lam
c0b0: 62 64 61 20 28 66 6e 61 6d 65 29 0a 3b 3b 3b 20 bda (fname).;;;
c0c0: 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 70 72 6f . ;; (print "pro
c0d0: 63 65 73 73 69 6e 67 20 66 6f 72 20 22 20 66 6e cessing for " fn
c0e0: 61 6d 65 29 0a 3b 3b 3b 20 09 20 3b 3b 28 70 72 ame).;;; . ;;(pr
c0f0: 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 69 65 73 ocess-db-queries
c100: 20 61 63 66 67 20 66 6e 61 6d 65 29 29 0a 3b 3b acfg fname)).;;
c110: 3b 20 09 20 28 6c 65 74 20 28 28 74 68 20 28 68 ; . (let ((th (h
c120: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
c130: 66 61 75 6c 74 20 74 68 72 65 61 64 73 20 66 6e fault threads fn
c140: 61 6d 65 20 23 66 29 29 29 0a 3b 3b 3b 20 09 20 ame #f))).;;; .
c150: 20 20 28 69 66 20 28 61 6e 64 20 74 68 20 28 6e (if (and th (n
c160: 6f 74 20 28 6d 65 6d 62 65 72 20 28 74 68 72 65 ot (member (thre
c170: 61 64 2d 73 74 61 74 65 20 74 68 29 20 27 28 64 ad-state th) '(d
c180: 65 61 64 20 74 65 72 6d 69 6e 61 74 65 64 29 29 ead terminated))
c190: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 )).;;; . (
c1a0: 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 28 70 72 begin.;;; .. (pr
c1b0: 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 77 6f int "WARNING: wo
c1c0: 72 6b 65 72 20 74 68 72 65 61 64 20 66 6f 72 20 rker thread for
c1d0: 22 20 66 6e 61 6d 65 20 22 20 69 73 20 74 61 6b " fname " is tak
c1e0: 69 6e 67 20 61 20 6c 6f 6e 67 20 74 69 6d 65 2e ing a long time.
c1f0: 22 29 0a 3b 3b 3b 20 09 09 20 28 70 72 69 6e 74 ").;;; .. (print
c200: 20 22 54 68 72 65 61 64 20 69 73 20 69 6e 20 73 "Thread is in s
c210: 74 61 74 65 20 22 20 28 74 68 72 65 61 64 2d 73 tate " (thread-s
c220: 74 61 74 65 20 74 68 29 29 29 0a 3b 3b 3b 20 09 tate th))).;;; .
c230: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 74 68 (let ((th
c240: 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 1 (make-thread (
c250: 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 09 09 lambda ().;;; ..
c260: 09 09 09 20 3b 3b 20 28 63 61 74 63 68 2d 61 6e ... ;; (catch-an
c270: 64 2d 64 75 6d 70 0a 3b 3b 3b 20 09 09 09 09 09 d-dump.;;; .....
c280: 20 3b 3b 20 20 28 6c 61 6d 62 64 61 20 28 29 0a ;; (lambda ().
c290: 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 3b 3b 20 ;;; ..... ;;
c2a0: 28 70 72 69 6e 74 20 22 50 72 6f 63 65 73 73 20 (print "Process
c2b0: 71 75 65 72 69 65 73 20 66 6f 72 20 22 20 66 6e queries for " fn
c2c0: 61 6d 65 29 0a 3b 3b 3b 20 09 09 09 09 09 20 20 ame).;;; .....
c2d0: 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 2d 74 (let ((start-t
c2e0: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c ime (current-mil
c2f0: 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b liseconds))).;;;
c300: 20 09 09 09 09 09 20 20 20 20 20 20 28 70 72 6f ..... (pro
c310: 63 65 73 73 2d 64 62 2d 71 75 65 72 69 65 73 20 cess-db-queries
c320: 61 63 66 67 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 acfg fname).;;;
c330: 09 09 09 09 09 20 20 20 20 20 20 3b 3b 20 28 74 ..... ;; (t
c340: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 hread-sleep! 0.0
c350: 31 29 20 3b 3b 20 6e 65 65 64 20 74 68 65 20 74 1) ;; need the t
c360: 68 72 65 61 64 20 74 6f 20 74 61 6b 65 20 61 74 hread to take at
c370: 20 6c 65 61 73 74 20 73 6f 6d 65 20 74 69 6d 65 least some time
c380: 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 20 20 .;;; .....
c390: 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 (hash-table-dele
c3a0: 74 65 21 20 74 68 72 65 61 64 73 20 66 6e 61 6d te! threads fnam
c3b0: 65 29 29 20 3b 3b 20 6e 6f 20 6d 75 74 65 78 65 e)) ;; no mutexe
c3c0: 73 3f 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 s?.;;; .....
c3d0: 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 09 09 09 09 fname).;;; .....
c3e0: 20 20 22 74 68 31 22 29 29 29 20 3b 3b 20 29 29 "th1"))) ;; ))
c3f0: 0a 3b 3b 3b 20 09 09 20 28 68 61 73 68 2d 74 61 .;;; .. (hash-ta
c400: 62 6c 65 2d 73 65 74 21 20 74 68 72 65 61 64 73 ble-set! threads
c410: 20 66 6e 61 6d 65 20 74 68 31 29 0a 3b 3b 3b 20 fname th1).;;;
c420: 09 09 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 .. (thread-start
c430: 21 20 74 68 31 29 29 29 29 29 0a 3b 3b 3b 20 20 ! th1))))).;;;
c440: 20 20 20 20 20 20 66 6e 61 6d 65 73 29 0a 3b 3b fnames).;;
c450: 3b 20 20 20 20 20 20 20 3b 3b 20 28 74 68 72 65 ; ;; (thre
c460: 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 20 3b ad-sleep! 0.1) ;
c470: 3b 20 67 69 76 65 20 74 68 65 20 74 68 72 65 61 ; give the threa
c480: 64 73 20 73 6f 6d 65 20 74 69 6d 65 20 74 6f 20 ds some time to
c490: 70 72 6f 63 65 73 73 20 72 65 71 75 65 73 74 73 process requests
c4a0: 0a 3b 3b 3b 20 20 20 20 20 20 20 3b 3b 20 62 75 .;;; ;; bu
c4b0: 72 6e 20 74 69 6d 65 20 75 6e 74 69 6c 20 34 30 rn time until 40
c4c0: 30 6d 73 20 69 73 20 75 70 0a 3b 3b 3b 20 20 20 0ms is up.;;;
c4d0: 20 20 20 20 28 6c 65 74 20 28 28 6e 6f 77 2d 74 (let ((now-t
c4e0: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c ime (current-mil
c4f0: 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b liseconds))).;;;
c500: 20 09 28 69 66 20 28 3c 20 6e 6f 77 2d 74 69 6d .(if (< now-tim
c510: 65 20 74 61 72 67 65 74 2d 74 69 6d 65 29 0a 3b e target-time).;
c520: 3b 3b 20 09 20 20 20 20 28 6c 65 74 20 28 28 64 ;; . (let ((d
c530: 65 6c 74 61 20 28 2d 20 74 61 72 67 65 74 2d 74 elta (- target-t
c540: 69 6d 65 20 6e 6f 77 2d 74 69 6d 65 29 29 29 0a ime now-time))).
c550: 3b 3b 3b 20 09 20 20 20 20 20 20 28 74 68 72 65 ;;; . (thre
c560: 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 64 65 6c ad-sleep! (/ del
c570: 74 61 20 31 30 30 30 29 29 29 29 29 0a 3b 3b 3b ta 1000))))).;;;
c580: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 68 61 (loop (ha
c590: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 28 61 sh-table-keys (a
c5a0: 72 65 61 2d 77 71 75 65 75 65 73 20 61 63 66 67 rea-wqueues acfg
c5b0: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 2b 20 28 )).;;; . (+ (
c5c0: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
c5d0: 6f 6e 64 73 29 20 35 30 29 29 29 29 29 0a 3b 3b onds) 50))))).;;
c5e0: 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d ; .;;; ;;=======
c5f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
c630: 3b 3b 3b 20 3b 3b 20 53 20 54 20 41 20 54 20 53 ;;; ;; S T A T S
c640: 20 20 20 47 20 41 20 54 20 48 20 45 20 52 20 49 G A T H E R I
c650: 20 4e 20 47 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d N G.;;; ;;=====
c660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c6a0: 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 73 =.;;; .;;; (defs
c6b0: 74 72 75 63 74 20 73 74 61 74 0a 3b 3b 3b 20 20 truct stat.;;;
c6c0: 20 28 71 63 6f 75 6e 74 2d 61 76 67 20 20 30 29 (qcount-avg 0)
c6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c6e0: 20 20 3b 3b 20 63 6f 61 72 73 65 20 72 75 6e 6e ;; coarse runn
c6f0: 69 6e 67 20 61 76 65 72 61 67 65 0a 3b 3b 3b 20 ing average.;;;
c700: 20 20 28 71 74 69 6d 65 2d 61 76 67 20 20 20 30 (qtime-avg 0
c710: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
c720: 20 20 20 3b 3b 20 63 6f 61 72 73 65 20 72 75 6e ;; coarse run
c730: 6e 69 6e 67 20 61 76 65 72 61 67 65 0a 3b 3b 3b ning average.;;;
c740: 20 20 20 28 71 63 6f 75 6e 74 20 20 20 20 20 20 (qcount
c750: 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
c760: 20 20 20 20 3b 3b 20 74 6f 74 61 6c 0a 3b 3b 3b ;; total.;;;
c770: 20 20 20 28 71 74 69 6d 65 20 20 20 20 20 20 20 (qtime
c780: 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
c790: 20 20 20 20 3b 3b 20 74 6f 74 61 6c 0a 3b 3b 3b ;; total.;;;
c7a0: 20 20 20 28 6c 61 73 74 2d 71 63 6f 75 6e 74 20 (last-qcount
c7b0: 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
c7c0: 20 20 20 20 3b 3b 20 6c 61 73 74 20 0a 3b 3b 3b ;; last .;;;
c7d0: 20 20 20 28 6c 61 73 74 2d 71 74 69 6d 65 20 20 (last-qtime
c7e0: 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
c7f0: 20 20 20 20 3b 3b 20 6c 61 73 74 0a 3b 3b 3b 20 ;; last.;;;
c800: 20 20 28 64 62 73 20 20 20 20 20 20 20 20 27 28 (dbs '(
c810: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
c820: 20 20 20 3b 3b 20 6c 69 73 74 20 6f 66 20 64 62 ;; list of db
c830: 20 66 69 6c 65 73 20 68 61 6e 64 6c 65 64 20 62 files handled b
c840: 79 20 74 68 69 73 20 6e 6f 64 65 0a 3b 3b 3b 20 y this node.;;;
c850: 20 20 28 77 68 65 6e 20 20 20 20 20 20 20 20 30 (when 0
c860: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
c870: 20 20 20 3b 3b 20 77 68 65 6e 20 74 68 65 20 6c ;; when the l
c880: 61 73 74 20 71 75 65 72 79 20 68 61 70 70 65 6e ast query happen
c890: 65 64 20 2d 20 73 65 63 6f 6e 64 73 0a 3b 3b 3b ed - seconds.;;;
c8a0: 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 .;;; .;;; (defi
c8b0: 6e 65 20 28 75 70 64 61 74 65 2d 73 74 61 74 73 ne (update-stats
c8c0: 20 61 63 66 67 20 66 6e 61 6d 65 20 62 75 63 6b acfg fname buck
c8d0: 65 74 20 64 75 72 61 74 69 6f 6e 20 6e 75 6d 71 et duration numq
c8e0: 75 65 72 69 65 73 29 0a 3b 3b 3b 20 20 20 28 6c ueries).;;; (l
c8f0: 65 74 2a 20 28 28 6b 65 79 20 20 20 66 6e 61 6d et* ((key fnam
c900: 65 29 20 3b 3b 20 66 6f 72 20 6e 6f 77 20 64 6f e) ;; for now do
c910: 20 6e 6f 74 20 75 73 65 20 62 75 63 6b 65 74 2e not use bucket.
c920: 20 57 61 73 3a 20 28 63 6f 6e 63 20 66 6e 61 6d Was: (conc fnam
c930: 65 20 22 2d 22 20 62 75 63 6b 65 74 29 29 20 3b e "-" bucket)) ;
c940: 3b 20 6c 61 7a 79 20 62 75 74 20 67 6f 6f 64 20 ; lazy but good
c950: 65 6e 6f 75 67 68 0a 3b 3b 3b 20 09 20 28 73 74 enough.;;; . (st
c960: 61 74 73 20 28 6f 72 20 28 68 61 73 68 2d 74 61 ats (or (hash-ta
c970: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
c980: 28 61 72 65 61 2d 73 74 61 74 73 20 61 63 66 67 (area-stats acfg
c990: 29 20 6b 65 79 20 23 66 29 0a 3b 3b 3b 20 09 09 ) key #f).;;; ..
c9a0: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 73 74 (let ((newst
c9b0: 61 74 73 20 28 6d 61 6b 65 2d 73 74 61 74 29 29 ats (make-stat))
c9c0: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 28 68 ).;;; .. (h
c9d0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
c9e0: 61 72 65 61 2d 73 74 61 74 73 20 61 63 66 67 29 area-stats acfg)
c9f0: 20 6b 65 79 20 6e 65 77 73 74 61 74 73 29 0a 3b key newstats).;
ca00: 3b 3b 20 09 09 20 20 20 20 20 20 6e 65 77 73 74 ;; .. newst
ca10: 61 74 73 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 ats)))).;;;
ca20: 3b 3b 20 77 68 65 6e 20 74 68 65 20 6c 61 73 74 ;; when the last
ca30: 20 71 75 65 72 79 20 68 61 70 70 65 6e 64 65 64 query happended
ca40: 20 28 75 73 65 64 20 74 6f 20 72 65 6d 6f 76 65 (used to remove
ca50: 20 74 68 65 20 66 6e 61 6d 65 20 66 72 6f 6d 20 the fname from
ca60: 74 68 65 20 61 63 74 69 76 65 20 6c 69 73 74 29 the active list)
ca70: 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 2d 77 .;;; (stat-w
ca80: 68 65 6e 2d 73 65 74 21 20 73 74 61 74 73 20 28 hen-set! stats (
ca90: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
caa0: 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 6c 61 73 ).;;; ;; las
cab0: 74 20 76 61 6c 75 65 73 0a 3b 3b 3b 20 20 20 20 t values.;;;
cac0: 20 28 73 74 61 74 2d 6c 61 73 74 2d 71 63 6f 75 (stat-last-qcou
cad0: 6e 74 2d 73 65 74 21 20 73 74 61 74 73 20 6e 75 nt-set! stats nu
cae0: 6d 71 75 65 72 69 65 73 29 0a 3b 3b 3b 20 20 20 mqueries).;;;
caf0: 20 20 28 73 74 61 74 2d 6c 61 73 74 2d 71 74 69 (stat-last-qti
cb00: 6d 65 2d 73 65 74 21 20 20 73 74 61 74 73 20 64 me-set! stats d
cb10: 75 72 61 74 69 6f 6e 29 0a 3b 3b 3b 20 20 20 20 uration).;;;
cb20: 20 3b 3b 20 74 6f 74 61 6c 20 6f 76 65 72 20 70 ;; total over p
cb30: 72 6f 63 65 73 73 20 6c 69 66 65 74 69 6d 65 0a rocess lifetime.
cb40: 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 2d 71 63 ;;; (stat-qc
cb50: 6f 75 6e 74 2d 73 65 74 21 20 73 74 61 74 73 20 ount-set! stats
cb60: 28 2b 20 28 73 74 61 74 2d 71 63 6f 75 6e 74 20 (+ (stat-qcount
cb70: 73 74 61 74 73 29 20 6e 75 6d 71 75 65 72 69 65 stats) numquerie
cb80: 73 29 29 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 s)).;;; (sta
cb90: 74 2d 71 74 69 6d 65 2d 73 65 74 21 20 20 73 74 t-qtime-set! st
cba0: 61 74 73 20 28 2b 20 28 73 74 61 74 2d 71 74 69 ats (+ (stat-qti
cbb0: 6d 65 20 20 73 74 61 74 73 29 20 64 75 72 61 74 me stats) durat
cbc0: 69 6f 6e 29 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b ion)).;;; ;;
cbd0: 20 63 6f 61 72 73 65 20 61 76 65 72 61 67 65 0a coarse average.
cbe0: 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 2d 71 63 ;;; (stat-qc
cbf0: 6f 75 6e 74 2d 61 76 67 2d 73 65 74 21 20 73 74 ount-avg-set! st
cc00: 61 74 73 20 28 2f 20 28 2b 20 28 73 74 61 74 2d ats (/ (+ (stat-
cc10: 71 63 6f 75 6e 74 2d 61 76 67 20 73 74 61 74 73 qcount-avg stats
cc20: 29 20 6e 75 6d 71 75 65 72 69 65 73 29 20 32 29 ) numqueries) 2)
cc30: 29 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 2d ).;;; (stat-
cc40: 71 74 69 6d 65 2d 61 76 67 2d 73 65 74 21 20 20 qtime-avg-set!
cc50: 73 74 61 74 73 20 28 2f 20 28 2b 20 28 73 74 61 stats (/ (+ (sta
cc60: 74 2d 71 74 69 6d 65 2d 61 76 67 20 20 73 74 61 t-qtime-avg sta
cc70: 74 73 29 20 64 75 72 61 74 69 6f 6e 29 20 20 20 ts) duration)
cc80: 32 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 2)).;;; .;;;
cc90: 20 3b 3b 20 68 65 72 65 20 69 73 20 77 68 65 72 ;; here is wher
cca0: 65 20 77 65 20 61 64 64 20 74 68 65 20 73 74 61 e we add the sta
ccb0: 74 73 20 66 6f 72 20 61 20 67 69 76 65 6e 20 64 ts for a given d
ccc0: 62 66 69 6c 65 0a 3b 3b 3b 20 20 20 20 20 28 69 bfile.;;; (i
ccd0: 66 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 66 f (not (member f
cce0: 6e 61 6d 65 20 28 73 74 61 74 2d 64 62 73 20 73 name (stat-dbs s
ccf0: 74 61 74 73 29 29 29 0a 3b 3b 3b 20 09 28 73 74 tats))).;;; .(st
cd00: 61 74 2d 64 62 73 2d 73 65 74 21 20 73 74 61 74 at-dbs-set! stat
cd10: 73 20 28 63 6f 6e 73 20 66 6e 61 6d 65 20 28 73 s (cons fname (s
cd20: 74 61 74 2d 64 62 73 20 73 74 61 74 73 29 29 29 tat-dbs stats)))
cd30: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 29 ).;;; .;;; )
cd40: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d ).;;; .;;; ;;===
cd50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cd60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cd70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cd80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cd90: 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 53 20 45 20 52 ===.;;; ;; S E R
cda0: 20 56 20 45 20 52 20 20 20 53 20 54 20 55 20 46 V E R S T U F
cdb0: 20 46 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d F .;;; ;;======
cdc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cdd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cde0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cdf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ce00: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 74 68 69 .;;; .;;; ;; thi
ce10: 73 20 64 6f 65 73 20 4e 4f 54 20 72 65 74 75 72 s does NOT retur
ce20: 6e 21 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 n!.;;; ;;.;;; (d
ce30: 65 66 69 6e 65 20 28 66 69 6e 64 2d 66 72 65 65 efine (find-free
ce40: 2d 70 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 61 -port-and-open a
ce50: 63 66 67 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 cfg).;;; (let
ce60: 28 28 70 6f 72 74 20 28 6f 72 20 28 61 72 65 61 ((port (or (area
ce70: 2d 70 6f 72 74 20 61 63 66 67 29 20 33 32 30 30 -port acfg) 3200
ce80: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 68 61 6e ))).;;; (han
ce90: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 3b dle-exceptions.;
cea0: 3b 3b 20 09 65 78 6e 0a 3b 3b 3b 20 09 28 62 65 ;; .exn.;;; .(be
ceb0: 67 69 6e 0a 3b 3b 3b 20 09 20 20 28 70 72 69 6e gin.;;; . (prin
cec0: 74 20 22 49 4e 46 4f 3a 20 63 61 6e 6e 6f 74 20 t "INFO: cannot
ced0: 62 69 6e 64 20 74 6f 20 70 6f 72 74 20 22 20 28 bind to port " (
cee0: 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 rpc:default-serv
cef0: 65 72 2d 70 6f 72 74 29 20 22 2c 20 74 72 79 69 er-port) ", tryi
cf00: 6e 67 20 6e 65 78 74 20 70 6f 72 74 22 29 0a 3b ng next port").;
cf10: 3b 3b 20 09 20 20 28 61 72 65 61 2d 70 6f 72 74 ;; . (area-port
cf20: 2d 73 65 74 21 20 61 63 66 67 20 28 2b 20 70 6f -set! acfg (+ po
cf30: 72 74 20 31 29 29 0a 3b 3b 3b 20 09 20 20 28 66 rt 1)).;;; . (f
cf40: 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e ind-free-port-an
cf50: 64 2d 6f 70 65 6e 20 61 63 66 67 29 29 0a 3b 3b d-open acfg)).;;
cf60: 3b 20 20 20 20 20 20 20 28 72 70 63 3a 64 65 66 ; (rpc:def
cf70: 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 74 ault-server-port
cf80: 20 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 20 20 20 port).;;;
cf90: 20 28 61 72 65 61 2d 70 6f 72 74 2d 73 65 74 21 (area-port-set!
cfa0: 20 61 63 66 67 20 70 6f 72 74 29 0a 3b 3b 3b 20 acfg port).;;;
cfb0: 20 20 20 20 20 20 28 74 63 70 2d 72 65 61 64 2d (tcp-read-
cfc0: 74 69 6d 65 6f 75 74 20 31 32 30 30 30 30 29 0a timeout 120000).
cfd0: 3b 3b 3b 20 20 20 20 20 20 20 3b 3b 20 28 28 72 ;;; ;; ((r
cfe0: 70 63 3a 6d 61 6b 65 2d 73 65 72 76 65 72 20 28 pc:make-server (
cff0: 74 63 70 2d 6c 69 73 74 65 6e 20 70 6f 72 74 29 tcp-listen port)
d000: 29 20 23 74 29 0a 3b 3b 3b 20 20 20 20 20 20 20 ) #t).;;;
d010: 28 74 63 70 2d 6c 69 73 74 65 6e 20 28 72 70 63 (tcp-listen (rpc
d020: 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 65 72 2d :default-server-
d030: 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 20 20 20 20 port).;;;
d040: 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b )))).;;; .;;; ;;
d050: 20 72 65 67 69 73 74 65 72 20 74 68 69 73 20 6e register this n
d060: 6f 64 65 20 62 79 20 70 75 74 74 69 6e 67 20 61 ode by putting a
d070: 20 70 61 63 6b 65 74 20 69 6e 74 6f 20 74 68 65 packet into the
d080: 20 70 6b 74 73 20 64 69 72 2e 0a 3b 3b 3b 20 3b pkts dir..;;; ;
d090: 3b 20 6c 6f 6f 6b 20 66 6f 72 20 6f 74 68 65 72 ; look for other
d0a0: 20 73 65 72 76 65 72 73 0a 3b 3b 3b 20 3b 3b 20 servers.;;; ;;
d0b0: 63 6f 6e 74 61 63 74 20 6f 74 68 65 72 20 73 65 contact other se
d0c0: 72 76 65 72 73 20 61 6e 64 20 63 6f 6d 70 69 6c rvers and compil
d0d0: 65 20 6c 69 73 74 20 6f 66 20 73 65 72 76 65 72 e list of server
d0e0: 73 0a 3b 3b 3b 20 3b 3b 20 74 68 65 72 65 20 61 s.;;; ;; there a
d0f0: 72 65 20 74 77 6f 20 74 79 70 65 73 20 6f 66 20 re two types of
d100: 73 65 72 76 65 72 0a 3b 3b 3b 20 3b 3b 20 20 20 server.;;; ;;
d110: 20 20 6d 61 69 6e 20 73 65 72 76 65 72 73 20 2d main servers -
d120: 20 64 61 73 68 62 6f 61 72 64 73 2c 20 72 75 6e dashboards, run
d130: 6e 65 72 73 20 61 6e 64 20 64 65 64 69 63 61 74 ners and dedicat
d140: 65 64 20 73 65 72 76 65 72 73 20 2d 20 6e 65 65 ed servers - nee
d150: 64 20 70 6b 74 0a 3b 3b 3b 20 3b 3b 20 20 20 20 d pkt.;;; ;;
d160: 20 70 61 73 73 69 76 65 20 73 65 72 76 65 72 73 passive servers
d170: 20 2d 20 74 65 73 74 20 65 78 65 63 75 74 65 72 - test executer
d180: 73 2c 20 73 74 65 70 20 63 61 6c 6c 73 2c 20 6c s, step calls, l
d190: 69 73 74 2d 72 75 6e 73 20 2d 20 6e 6f 20 70 6b ist-runs - no pk
d1a0: 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 t.;;; ;;.;;; (de
d1b0: 66 69 6e 65 20 28 72 65 67 69 73 74 65 72 2d 6e fine (register-n
d1c0: 6f 64 65 20 61 63 66 67 20 68 6f 73 74 69 70 20 ode acfg hostip
d1d0: 70 6f 72 74 2d 6e 75 6d 29 0a 3b 3b 3b 20 20 20 port-num).;;;
d1e0: 3b 3b 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 28 ;;(mutex-lock! (
d1f0: 61 72 65 61 2d 6d 75 74 65 78 20 61 63 66 67 29 area-mutex acfg)
d200: 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 ).;;; (let* ((
d210: 73 65 72 76 65 72 2d 74 79 70 65 20 20 28 61 72 server-type (ar
d220: 65 61 2d 73 65 72 76 65 72 2d 74 79 70 65 20 61 ea-server-type a
d230: 63 66 67 29 29 20 3b 3b 20 61 75 74 6f 2c 20 6d cfg)) ;; auto, m
d240: 61 69 6e 2c 20 70 61 73 73 69 76 65 20 28 6e 6f ain, passive (no
d250: 20 70 6b 74 20 63 72 65 61 74 65 64 29 0a 3b 3b pkt created).;;
d260: 3b 20 09 20 28 62 65 73 74 2d 69 70 20 20 20 20 ; . (best-ip
d270: 20 20 28 6f 72 20 68 6f 73 74 69 70 20 28 67 65 (or hostip (ge
d280: 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 73 t-my-best-addres
d290: 73 29 29 29 0a 3b 3b 3b 20 09 20 28 6d 74 64 69 s))).;;; . (mtdi
d2a0: 72 20 20 20 20 20 20 20 20 28 61 72 65 61 2d 64 r (area-d
d2b0: 62 64 69 72 20 61 63 66 67 29 29 0a 3b 3b 3b 20 bdir acfg)).;;;
d2c0: 09 20 28 70 6b 74 64 69 72 20 20 20 20 20 20 20 . (pktdir
d2d0: 28 61 72 65 61 2d 70 6b 74 73 64 69 72 20 61 63 (area-pktsdir ac
d2e0: 66 67 29 29 29 20 3b 3b 20 63 6f 6e 63 20 6d 74 fg))) ;; conc mt
d2f0: 64 69 72 20 22 2f 2e 73 65 72 76 65 72 2d 70 6b dir "/.server-pk
d300: 74 73 22 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 ts"))).;;; (
d310: 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 72 69 print "Registeri
d320: 6e 67 20 6e 6f 64 65 20 22 20 62 65 73 74 2d 69 ng node " best-i
d330: 70 20 22 3a 22 20 70 6f 72 74 2d 6e 75 6d 29 0a p ":" port-num).
d340: 3b 3b 3b 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ;;; (if (not
d350: 20 6d 74 64 69 72 29 20 3b 3b 20 72 65 71 75 69 mtdir) ;; requi
d360: 72 65 20 61 20 68 6f 6d 65 20 66 6f 72 20 74 68 re a home for th
d370: 69 73 20 6e 6f 64 65 20 74 6f 20 70 75 74 20 6f is node to put o
d380: 72 20 66 69 6e 64 20 64 61 74 61 62 61 73 65 73 r find databases
d390: 0a 3b 3b 3b 20 09 23 66 0a 3b 3b 3b 20 09 28 62 .;;; .#f.;;; .(b
d3a0: 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 28 69 66 20 egin.;;; . (if
d3b0: 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 79 (not (directory
d3c0: 3f 20 70 6b 74 64 69 72 29 29 28 63 72 65 61 74 ? pktdir))(creat
d3d0: 65 2d 64 69 72 65 63 74 6f 72 79 20 70 6b 74 64 e-directory pktd
d3e0: 69 72 29 29 0a 3b 3b 3b 20 09 20 20 3b 3b 20 73 ir)).;;; . ;; s
d3f0: 65 72 76 65 72 20 69 73 20 73 74 61 72 74 65 64 erver is started
d400: 2c 20 6e 6f 77 20 63 72 65 61 74 65 20 70 6b 74 , now create pkt
d410: 20 69 66 20 6e 65 65 64 65 64 0a 3b 3b 3b 20 09 if needed.;;; .
d420: 20 20 28 70 72 69 6e 74 20 22 53 74 61 72 74 69 (print "Starti
d430: 6e 67 20 73 65 72 76 65 72 20 69 6e 20 22 20 73 ng server in " s
d440: 65 72 76 65 72 2d 74 79 70 65 20 22 20 6d 6f 64 erver-type " mod
d450: 65 20 77 69 74 68 20 70 6f 72 74 20 22 20 70 6f e with port " po
d460: 72 74 2d 6e 75 6d 29 0a 3b 3b 3b 20 09 20 20 28 rt-num).;;; . (
d470: 69 66 20 28 6d 65 6d 62 65 72 20 73 65 72 76 65 if (member serve
d480: 72 2d 74 79 70 65 20 27 28 61 75 74 6f 20 6d 61 r-type '(auto ma
d490: 69 6e 29 29 20 3b 3b 20 54 4f 44 4f 3a 20 69 66 in)) ;; TODO: if
d4a0: 20 61 75 74 6f 2c 20 63 6f 75 6e 74 20 6e 75 6d auto, count num
d4b0: 62 65 72 20 6f 66 20 73 65 72 76 65 72 73 20 72 ber of servers r
d4c0: 65 67 69 73 74 65 72 73 2c 20 69 66 20 3e 20 33 egisters, if > 3
d4d0: 20 74 68 65 6e 20 64 6f 6e 27 74 20 70 75 74 20 then don't put
d4e0: 6f 75 74 20 61 20 70 6b 74 0a 3b 3b 3b 20 09 20 out a pkt.;;; .
d4f0: 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 (begin.;;;
d500: 09 09 28 61 72 65 61 2d 70 6b 74 69 64 2d 73 65 ..(area-pktid-se
d510: 74 21 20 61 63 66 67 0a 3b 3b 3b 20 09 09 09 09 t! acfg.;;; ....
d520: 20 28 77 72 69 74 65 2d 61 6c 69 73 74 2d 3e 70 (write-alist->p
d530: 6b 74 0a 3b 3b 3b 20 09 09 09 09 20 20 70 6b 74 kt.;;; .... pkt
d540: 64 69 72 20 0a 3b 3b 3b 20 09 09 09 09 20 20 60 dir .;;; .... `
d550: 28 28 68 6f 73 74 6e 61 6d 65 20 2e 20 2c 28 67 ((hostname . ,(g
d560: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 3b et-host-name)).;
d570: 3b 3b 20 09 09 09 09 20 20 20 20 28 69 70 61 64 ;; .... (ipad
d580: 64 72 20 20 20 2e 20 2c 62 65 73 74 2d 69 70 29 dr . ,best-ip)
d590: 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 28 70 6f .;;; .... (po
d5a0: 72 74 20 20 20 20 20 2e 20 2c 70 6f 72 74 2d 6e rt . ,port-n
d5b0: 75 6d 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 um).;;; ....
d5c0: 28 70 69 64 20 20 20 20 20 20 2e 20 2c 28 63 75 (pid . ,(cu
d5d0: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
d5e0: 29 29 29 0a 3b 3b 3b 20 09 09 09 09 20 20 70 6b ))).;;; .... pk
d5f0: 74 73 70 65 63 3a 20 2a 70 6b 74 73 70 65 63 2a tspec: *pktspec*
d600: 0a 3b 3b 3b 20 09 09 09 09 20 20 70 74 79 70 65 .;;; .... ptype
d610: 3a 20 20 20 27 73 65 72 76 65 72 29 29 0a 3b 3b : 'server)).;;
d620: 3b 20 09 09 28 61 72 65 61 2d 70 6b 74 66 69 6c ; ..(area-pktfil
d630: 65 2d 73 65 74 21 20 61 63 66 67 20 28 63 6f 6e e-set! acfg (con
d640: 63 20 70 6b 74 64 69 72 20 22 2f 22 20 28 61 72 c pktdir "/" (ar
d650: 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 20 22 ea-pktid acfg) "
d660: 2e 70 6b 74 22 29 29 29 29 0a 3b 3b 3b 20 09 20 .pkt")))).;;; .
d670: 20 28 61 72 65 61 2d 70 6f 72 74 2d 73 65 74 21 (area-port-set!
d680: 20 20 20 20 61 63 66 67 20 70 6f 72 74 2d 6e 75 acfg port-nu
d690: 6d 29 0a 3b 3b 3b 20 09 20 20 23 3b 28 6d 75 74 m).;;; . #;(mut
d6a0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 28 61 72 65 61 ex-unlock! (area
d6b0: 2d 6d 75 74 65 78 20 61 63 66 67 29 29 29 29 29 -mutex acfg)))))
d6c0: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 ).;;; .;;; (defi
d6d0: 6e 65 20 2a 63 6f 6f 6b 69 65 2d 73 65 71 6e 75 ne *cookie-seqnu
d6e0: 6d 2a 20 30 29 0a 3b 3b 3b 20 28 64 65 66 69 6e m* 0).;;; (defin
d6f0: 65 20 28 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 6b e (make-cookie k
d700: 65 79 29 0a 3b 3b 3b 20 20 20 28 73 65 74 21 20 ey).;;; (set!
d710: 2a 63 6f 6f 6b 69 65 2d 73 65 71 6e 75 6d 2a 20 *cookie-seqnum*
d720: 28 61 64 64 31 20 2a 63 6f 6f 6b 69 65 2d 73 65 (add1 *cookie-se
d730: 71 6e 75 6d 2a 29 29 0a 3b 3b 3b 20 20 20 3b 3b qnum*)).;;; ;;
d740: 28 70 72 69 6e 74 20 22 4d 41 4b 45 20 43 4f 4f (print "MAKE COO
d750: 4b 49 45 20 43 41 4c 4c 45 44 20 2d 2d 20 6f 6e KIE CALLED -- on
d760: 20 22 73 65 72 76 6b 65 79 22 2d 22 2a 63 6f 6f "servkey"-"*coo
d770: 6b 69 65 2d 73 65 71 6e 75 6d 2a 29 0a 3b 3b 3b kie-seqnum*).;;;
d780: 20 20 20 28 63 6f 6e 63 20 6b 65 79 20 22 2d 22 (conc key "-"
d790: 20 2a 63 6f 6f 6b 69 65 2d 73 65 71 6e 75 6d 2a *cookie-seqnum*
d7a0: 29 0a 3b 3b 3b 20 20 20 29 0a 3b 3b 3b 20 0a 3b ).;;; ).;;; .;
d7b0: 3b 3b 20 3b 3b 20 64 69 73 70 61 74 63 68 20 6c ;; ;; dispatch l
d7c0: 6f 63 61 6c 6c 79 20 69 66 20 70 6f 73 73 69 62 ocally if possib
d7d0: 6c 65 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 le.;;; ;;.;;; (d
d7e0: 65 66 69 6e 65 20 28 63 61 6c 6c 2d 64 65 6c 69 efine (call-deli
d7f0: 76 65 72 2d 72 65 73 70 6f 6e 73 65 20 61 63 66 ver-response acf
d800: 67 20 69 70 61 64 64 72 20 70 6f 72 74 20 63 6f g ipaddr port co
d810: 6f 6b 69 65 20 64 61 74 61 29 0a 3b 3b 3b 20 20 okie data).;;;
d820: 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c (if (and (equal
d830: 3f 20 28 61 72 65 61 2d 6d 79 61 64 64 72 20 61 ? (area-myaddr a
d840: 63 66 67 29 20 69 70 61 64 64 72 29 0a 3b 3b 3b cfg) ipaddr).;;;
d850: 20 09 20 20 20 28 65 71 75 61 6c 3f 20 28 61 72 . (equal? (ar
d860: 65 61 2d 70 6f 72 74 20 20 20 20 20 61 63 66 67 ea-port acfg
d870: 29 20 70 6f 72 74 29 29 0a 3b 3b 3b 20 20 20 20 ) port)).;;;
d880: 20 20 20 28 64 65 6c 69 76 65 72 2d 72 65 73 70 (deliver-resp
d890: 6f 6e 73 65 20 61 63 66 67 20 63 6f 6f 6b 69 65 onse acfg cookie
d8a0: 20 64 61 74 61 29 0a 3b 3b 3b 20 20 20 20 20 20 data).;;;
d8b0: 20 28 28 72 70 63 3a 70 72 6f 63 65 64 75 72 65 ((rpc:procedure
d8c0: 20 27 72 65 73 70 6f 6e 73 65 20 69 70 61 64 64 'response ipadd
d8d0: 72 20 70 6f 72 74 29 20 63 6f 6f 6b 69 65 20 64 r port) cookie d
d8e0: 61 74 61 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 ata))).;;; .;;;
d8f0: 28 64 65 66 69 6e 65 20 28 64 65 6c 69 76 65 72 (define (deliver
d900: 2d 72 65 73 70 6f 6e 73 65 20 61 63 66 67 20 63 -response acfg c
d910: 6f 6f 6b 69 65 20 64 61 74 61 29 0a 3b 3b 3b 20 ookie data).;;;
d920: 20 20 28 6c 65 74 20 28 28 64 65 6c 69 76 65 72 (let ((deliver
d930: 2d 72 65 73 70 6f 6e 73 65 2d 73 74 61 72 74 20 -response-start
d940: 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 (current-millise
d950: 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 20 20 20 conds))).;;;
d960: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
d970: 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 3b 3b 3b (make-thread.;;;
d980: 20 09 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
d990: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 28 6c ).;;; .. (l
d9a0: 65 74 20 6c 6f 6f 70 20 28 28 74 72 69 65 73 2d et loop ((tries-
d9b0: 6c 65 66 74 20 35 29 29 0a 3b 3b 3b 20 09 09 09 left 5)).;;; ...
d9c0: 3b 3b 28 70 72 69 6e 74 20 22 54 4f 50 20 4f 46 ;;(print "TOP OF
d9d0: 20 44 45 4c 49 56 45 52 5f 52 45 53 50 4f 4e 53 DELIVER_RESPONS
d9e0: 45 20 4c 4f 4f 50 3b 20 74 72 69 65 73 6c 65 66 E LOOP; trieslef
d9f0: 74 3d 22 74 72 69 65 73 2d 6c 65 66 74 29 0a 3b t="tries-left).;
da00: 3b 3b 20 09 09 09 3b 3b 28 70 70 20 28 68 61 73 ;; ...;;(pp (has
da10: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 28 h-table->alist (
da20: 61 72 65 61 2d 63 6f 6f 6b 69 65 32 6d 62 6f 78 area-cookie2mbox
da30: 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 09 09 09 acfg))).;;; ...
da40: 28 6c 65 74 2a 20 28 28 6d 62 6f 78 20 28 68 61 (let* ((mbox (ha
da50: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
da60: 61 75 6c 74 20 28 61 72 65 61 2d 63 6f 6f 6b 69 ault (area-cooki
da70: 65 32 6d 62 6f 78 20 61 63 66 67 29 20 63 6f 6f e2mbox acfg) coo
da80: 6b 69 65 20 23 66 29 29 29 0a 3b 3b 3b 20 09 09 kie #f))).;;; ..
da90: 09 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 09 09 09 . (cond.;;; ...
daa0: 20 20 20 28 28 65 71 3f 20 30 20 74 72 69 65 73 ((eq? 0 tries
dab0: 2d 6c 65 66 74 29 0a 3b 3b 3b 20 09 09 09 20 20 -left).;;; ...
dac0: 20 20 28 70 72 69 6e 74 20 22 75 6c 65 78 3a 64 (print "ulex:d
dad0: 65 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 65 3a eliver-response:
dae0: 20 49 20 67 69 76 65 20 75 70 2e 20 4d 61 69 6c I give up. Mail
daf0: 62 6f 78 20 6e 65 76 65 72 20 61 70 70 65 61 72 box never appear
db00: 65 64 2e 20 63 6f 6f 6b 69 65 3d 22 63 6f 6f 6b ed. cookie="cook
db10: 69 65 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 29 ie).;;; ... )
db20: 0a 3b 3b 3b 20 09 09 09 20 20 20 28 6d 62 6f 78 .;;; ... (mbox
db30: 0a 3b 3b 3b 20 09 09 09 20 20 20 20 3b 3b 28 70 .;;; ... ;;(p
db40: 72 69 6e 74 20 22 67 6f 74 20 6d 62 6f 78 3d 22 rint "got mbox="
db50: 6d 62 6f 78 22 20 20 67 6f 74 20 64 61 74 61 3d mbox" got data=
db60: 22 64 61 74 61 22 20 20 73 65 6e 64 2e 22 29 0a "data" send.").
db70: 3b 3b 3b 20 09 09 09 20 20 20 20 28 6d 61 69 6c ;;; ... (mail
db80: 62 6f 78 2d 73 65 6e 64 21 20 6d 62 6f 78 20 64 box-send! mbox d
db90: 61 74 61 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 ata)).;;; ...
dba0: 28 65 6c 73 65 0a 3b 3b 3b 20 09 09 09 20 20 20 (else.;;; ...
dbb0: 20 3b 3b 28 70 72 69 6e 74 20 22 6e 6f 20 6d 62 ;;(print "no mb
dbc0: 6f 78 20 79 65 74 2e 20 20 6c 6f 6f 6b 20 66 6f ox yet. look fo
dbd0: 72 20 22 63 6f 6f 6b 69 65 29 0a 3b 3b 3b 20 09 r "cookie).;;; .
dbe0: 09 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c .. (thread-sl
dbf0: 65 65 70 21 20 28 2f 20 28 2d 20 36 20 74 72 69 eep! (/ (- 6 tri
dc00: 65 73 2d 6c 65 66 74 29 20 31 30 29 29 0a 3b 3b es-left) 10)).;;
dc10: 3b 20 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 ; ... (loop (
dc20: 73 75 62 31 20 74 72 69 65 73 2d 6c 65 66 74 29 sub1 tries-left)
dc30: 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 ))))).;;; ..
dc40: 20 20 3b 3b 20 28 64 65 62 75 67 2d 70 70 20 28 ;; (debug-pp (
dc50: 6c 69 73 74 20 28 63 6f 6e 63 20 22 75 6c 65 78 list (conc "ulex
dc60: 3a 64 65 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 :deliver-respons
dc70: 65 20 74 6f 6f 6b 20 22 20 28 2d 20 28 63 75 72 e took " (- (cur
dc80: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
dc90: 73 29 20 64 65 6c 69 76 65 72 2d 72 65 73 70 6f s) deliver-respo
dca0: 6e 73 65 2d 73 74 61 72 74 29 20 22 20 6d 73 2c nse-start) " ms,
dcb0: 20 63 6f 6f 6b 69 65 3d 22 20 63 6f 6f 6b 69 65 cookie=" cookie
dcc0: 20 22 20 64 61 74 61 3d 22 29 20 64 61 74 61 29 " data=") data)
dcd0: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 28 73 ).;;; .. (s
dce0: 64 62 67 3e 20 22 64 65 6c 69 76 65 72 2d 72 65 dbg> "deliver-re
dcf0: 73 70 6f 6e 73 65 22 20 22 6d 61 69 6c 62 6f 78 sponse" "mailbox
dd00: 2d 73 65 6e 64 22 20 64 65 6c 69 76 65 72 2d 72 -send" deliver-r
dd10: 65 73 70 6f 6e 73 65 2d 73 74 61 72 74 20 23 66 esponse-start #f
dd20: 20 23 66 20 63 6f 6f 6b 69 65 29 0a 3b 3b 3b 20 #f cookie).;;;
dd30: 09 09 20 20 20 20 20 20 29 0a 3b 3b 3b 20 09 09 .. ).;;; ..
dd40: 20 20 20 20 28 63 6f 6e 63 20 22 64 65 6c 69 76 (conc "deliv
dd50: 65 72 2d 72 65 73 70 6f 6e 73 65 20 74 68 72 65 er-response thre
dd60: 61 64 20 66 6f 72 20 63 6f 6f 6b 69 65 3d 22 63 ad for cookie="c
dd70: 6f 6f 6b 69 65 29 29 29 29 0a 3b 3b 3b 20 20 20 ookie)))).;;;
dd80: 23 74 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 #t).;;; .;;; ;;
dd90: 61 63 74 69 6f 6e 3a 0a 3b 3b 3b 20 3b 3b 20 20 action:.;;; ;;
dda0: 20 69 6d 6d 65 64 69 61 74 65 20 2d 20 71 75 69 immediate - qui
ddb0: 63 6b 20 61 63 74 69 6f 6e 73 2c 20 6e 6f 20 6e ck actions, no n
ddc0: 65 65 64 20 74 6f 20 70 75 74 20 69 6e 20 71 75 eed to put in qu
ddd0: 65 75 65 73 0a 3b 3b 3b 20 3b 3b 20 20 20 64 62 eues.;;; ;; db
dde0: 77 72 69 74 65 20 20 20 2d 20 70 75 74 20 69 6e write - put in
ddf0: 20 64 62 77 72 69 74 65 20 71 75 65 75 65 0a 3b dbwrite queue.;
de00: 3b 3b 20 3b 3b 20 20 20 64 62 72 65 61 64 20 20 ;; ;; dbread
de10: 20 20 2d 20 70 75 74 20 69 6e 20 64 62 72 65 61 - put in dbrea
de20: 64 20 71 75 65 75 65 0a 3b 3b 3b 20 3b 3b 20 20 d queue.;;; ;;
de30: 20 6f 73 6c 6f 6e 67 20 20 20 20 2d 20 6f 73 20 oslong - os
de40: 61 63 74 69 6f 6e 73 2c 20 65 2e 67 2e 20 64 75 actions, e.g. du
de50: 2c 20 74 68 61 74 20 63 6f 75 6c 64 20 74 61 6b , that could tak
de60: 65 20 61 20 6c 6f 6e 67 20 74 69 6d 65 0a 3b 3b e a long time.;;
de70: 3b 20 3b 3b 20 20 20 6f 73 73 68 6f 72 74 20 20 ; ;; osshort
de80: 20 2d 20 6f 73 20 61 63 74 69 6f 6e 73 20 74 68 - os actions th
de90: 61 74 20 73 68 6f 75 6c 64 20 62 65 20 71 75 69 at should be qui
dea0: 63 6b 2c 20 65 2e 67 2e 20 64 66 0a 3b 3b 3b 20 ck, e.g. df.;;;
deb0: 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;.;;; (define (
dec0: 72 65 71 75 65 73 74 20 61 63 66 67 20 66 72 6f request acfg fro
ded0: 6d 2d 69 70 61 64 64 72 20 66 72 6f 6d 2d 70 6f m-ipaddr from-po
dee0: 72 74 20 73 65 72 76 6b 65 79 20 61 63 74 69 6f rt servkey actio
def0: 6e 20 63 6f 6f 6b 69 65 20 66 6e 61 6d 65 20 70 n cookie fname p
df00: 61 72 61 6d 73 29 20 3b 3b 20 73 74 64 2d 70 65 arams) ;; std-pe
df10: 65 72 2d 68 61 6e 64 6c 65 72 0a 3b 3b 3b 20 20 er-handler.;;;
df20: 20 3b 3b 20 4e 4f 54 45 3a 20 55 73 65 20 72 70 ;; NOTE: Use rp
df30: 63 3a 63 75 72 72 65 6e 74 2d 70 65 65 72 20 66 c:current-peer f
df40: 6f 72 20 67 65 74 74 69 6e 67 20 72 65 74 75 72 or getting retur
df50: 6e 20 61 64 64 72 65 73 73 0a 3b 3b 3b 20 20 20 n address.;;;
df60: 28 6c 65 74 2a 20 28 28 73 74 64 2d 70 65 65 72 (let* ((std-peer
df70: 2d 68 61 6e 64 6c 65 72 2d 73 74 61 72 74 20 28 -handler-start (
df80: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
df90: 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 3b 3b 20 onds)).;;; . ;;
dfa0: 28 72 61 77 2d 64 61 74 61 20 20 20 20 20 20 20 (raw-data
dfb0: 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 (alist-r
dfc0: 65 66 20 27 64 61 74 61 20 20 20 20 20 64 61 74 ef 'data dat
dfd0: 29 29 0a 3b 3b 3b 20 09 20 28 72 64 61 74 20 20 )).;;; . (rdat
dfe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dff0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
e000: 2f 64 65 66 61 75 6c 74 0a 3b 3b 3b 20 09 09 09 /default.;;; ...
e010: 09 20 20 28 61 72 65 61 2d 72 74 61 62 6c 65 20 . (area-rtable
e020: 61 63 66 67 29 20 61 63 74 69 6f 6e 20 23 66 29 acfg) action #f)
e030: 29 20 3b 3b 20 74 68 69 73 20 6c 6f 6f 6b 73 20 ) ;; this looks
e040: 75 70 20 74 68 65 20 73 71 6c 20 71 75 65 72 79 up the sql query
e050: 20 6f 72 20 6f 74 68 65 72 20 64 65 74 61 69 6c or other detail
e060: 73 20 69 6e 64 65 78 65 64 20 62 79 20 74 68 65 s indexed by the
e070: 20 61 63 74 69 6f 6e 0a 3b 3b 3b 20 09 20 28 77 action.;;; . (w
e080: 69 74 65 6d 20 20 20 20 20 20 20 20 20 20 20 20 item
e090: 20 20 20 20 20 20 28 6d 61 6b 65 2d 77 69 74 65 (make-wite
e0a0: 6d 20 72 69 70 61 64 64 72 3a 20 66 72 6f 6d 2d m ripaddr: from-
e0b0: 69 70 61 64 64 72 20 3b 3b 20 72 68 6f 73 74 3a ipaddr ;; rhost:
e0c0: 20 20 20 66 72 6f 6d 2d 68 6f 73 74 20 20 20 0a from-host .
e0d0: 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 20 72 70 ;;; ..... rp
e0e0: 6f 72 74 3a 20 20 20 66 72 6f 6d 2d 70 6f 72 74 ort: from-port
e0f0: 20 20 20 61 63 74 69 6f 6e 3a 20 20 61 63 74 69 action: acti
e100: 6f 6e 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 on.;;; .....
e110: 20 72 64 61 74 3a 20 20 20 20 72 64 61 74 20 20 rdat: rdat
e120: 20 20 20 20 20 20 63 6f 6f 6b 69 65 3a 20 20 63 cookie: c
e130: 6f 6f 6b 69 65 0a 3b 3b 3b 20 09 09 09 09 09 20 ookie.;;; .....
e140: 20 20 20 20 73 65 72 76 6b 65 79 3a 20 73 65 72 servkey: ser
e150: 76 6b 65 79 20 20 20 20 20 64 61 74 61 3a 20 20 vkey data:
e160: 20 20 70 61 72 61 6d 73 20 3b 3b 20 54 4f 44 4f params ;; TODO
e170: 20 2d 20 72 65 6e 61 6d 65 20 64 61 74 61 20 74 - rename data t
e180: 6f 20 70 61 72 61 6d 73 0a 3b 3b 3b 20 09 09 09 o params.;;; ...
e190: 09 09 20 20 20 20 20 63 61 6c 6c 65 72 3a 20 20 .. caller:
e1a0: 28 72 70 63 3a 63 75 72 72 65 6e 74 2d 70 65 65 (rpc:current-pee
e1b0: 72 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 r)))).;;; (i
e1c0: 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 f (not (equal? s
e1d0: 65 72 76 6b 65 79 20 28 61 72 65 61 2d 70 6b 74 ervkey (area-pkt
e1e0: 69 64 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 09 id acfg))).;;; .
e1f0: 60 28 23 66 20 2e 20 2c 28 63 6f 6e 63 20 22 49 `(#f . ,(conc "I
e200: 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 79 6f 75 20 don't know you
e210: 73 65 72 76 6b 65 79 3d 22 20 73 65 72 76 6b 65 servkey=" servke
e220: 79 20 22 2c 20 70 6b 74 69 64 3d 22 20 28 61 72 y ", pktid=" (ar
e230: 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 29 29 ea-pktid acfg)))
e240: 20 3b 3b 20 69 6d 6d 65 64 69 61 74 65 6c 79 20 ;; immediately
e250: 72 65 74 75 72 6e 20 74 68 69 73 0a 3b 3b 3b 20 return this.;;;
e260: 09 28 6c 65 74 2a 20 28 28 63 74 79 70 65 20 28 .(let* ((ctype (
e270: 69 66 20 72 64 61 74 20 0a 3b 3b 3b 20 09 09 09 if rdat .;;; ...
e280: 20 20 28 63 61 6c 6c 64 61 74 2d 63 74 79 70 65 (calldat-ctype
e290: 20 72 64 61 74 29 20 3b 3b 20 69 73 20 74 68 69 rdat) ;; is thi
e2a0: 73 20 6e 65 63 65 73 73 61 72 79 3f 20 74 68 65 s necessary? the
e2b0: 73 65 20 73 68 6f 75 6c 64 20 62 65 20 69 64 65 se should be ide
e2c0: 6e 74 69 63 61 6c 0a 3b 3b 3b 20 09 09 09 20 20 ntical.;;; ...
e2d0: 61 63 74 69 6f 6e 29 29 29 0a 3b 3b 3b 20 09 20 action))).;;; .
e2e0: 20 28 73 64 62 67 3e 20 22 73 74 64 2d 70 65 65 (sdbg> "std-pee
e2f0: 72 2d 68 61 6e 64 6c 65 72 22 20 22 69 6d 6d 65 r-handler" "imme
e300: 64 69 61 74 65 22 20 73 74 64 2d 70 65 65 72 2d diate" std-peer-
e310: 68 61 6e 64 6c 65 72 2d 73 74 61 72 74 20 23 66 handler-start #f
e320: 20 23 66 29 0a 3b 3b 3b 20 09 20 20 28 63 61 73 #f).;;; . (cas
e330: 65 20 63 74 79 70 65 0a 3b 3b 3b 20 09 20 20 20 e ctype.;;; .
e340: 20 3b 3b 20 28 64 62 77 72 69 74 65 20 61 63 66 ;; (dbwrite acf
e350: 67 20 72 64 61 74 20 28 63 6f 6e 73 20 66 72 6f g rdat (cons fro
e360: 6d 2d 69 70 61 64 64 72 20 66 72 6f 6d 2d 70 6f m-ipaddr from-po
e370: 72 74 29 20 64 61 74 61 29 29 29 0a 3b 3b 3b 20 rt) data))).;;;
e380: 09 20 20 20 20 28 28 66 75 6c 6c 2d 70 69 6e 67 . ((full-ping
e390: 29 20 20 60 28 23 74 20 20 22 61 63 6b 20 74 6f ) `(#t "ack to
e3a0: 20 66 75 6c 6c 20 70 69 6e 67 22 20 20 20 20 20 full ping"
e3b0: 20 20 20 2c 28 77 6f 72 6b 2d 71 75 65 75 65 2d ,(work-queue-
e3c0: 61 64 64 20 61 63 66 67 20 66 6e 61 6d 65 20 77 add acfg fname w
e3d0: 69 74 65 6d 29 20 2c 63 6f 6f 6b 69 65 29 29 0a item) ,cookie)).
e3e0: 3b 3b 3b 20 09 20 20 20 20 28 28 72 65 73 70 6f ;;; . ((respo
e3f0: 6e 73 65 29 20 20 20 60 28 23 74 20 20 22 61 63 nse) `(#t "ac
e400: 6b 20 66 72 6f 6d 20 72 65 71 75 65 73 74 6f 72 k from requestor
e410: 22 20 20 20 20 20 20 2c 28 64 65 6c 69 76 65 72 " ,(deliver
e420: 2d 72 65 73 70 6f 6e 73 65 20 61 63 66 67 20 66 -response acfg f
e430: 6e 61 6d 65 20 70 61 72 61 6d 73 29 29 29 0a 3b name params))).;
e440: 3b 3b 20 09 20 20 20 20 28 28 64 62 77 72 69 74 ;; . ((dbwrit
e450: 65 29 20 20 20 20 60 28 23 74 20 20 22 64 62 20 e) `(#t "db
e460: 77 72 69 74 65 20 73 75 62 6d 69 74 74 65 64 22 write submitted"
e470: 20 20 20 20 20 20 2c 28 77 6f 72 6b 2d 71 75 65 ,(work-que
e480: 75 65 2d 61 64 64 20 61 63 66 67 20 66 6e 61 6d ue-add acfg fnam
e490: 65 20 77 69 74 65 6d 29 20 2c 63 6f 6f 6b 69 65 e witem) ,cookie
e4a0: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 28 64 62 )).;;; . ((db
e4b0: 72 65 61 64 29 20 20 20 20 20 60 28 23 74 20 20 read) `(#t
e4c0: 22 64 62 20 72 65 61 64 20 73 75 62 6d 69 74 74 "db read submitt
e4d0: 65 64 22 20 20 20 20 20 20 20 2c 28 77 6f 72 6b ed" ,(work
e4e0: 2d 71 75 65 75 65 2d 61 64 64 20 61 63 66 67 20 -queue-add acfg
e4f0: 66 6e 61 6d 65 20 77 69 74 65 6d 29 20 2c 63 6f fname witem) ,co
e500: 6f 6b 69 65 20 20 29 29 0a 3b 3b 3b 20 09 20 20 okie )).;;; .
e510: 20 20 28 28 64 62 72 77 29 20 20 20 20 20 20 20 ((dbrw)
e520: 60 28 23 74 20 20 22 64 62 20 72 65 61 64 2f 77 `(#t "db read/w
e530: 72 69 74 65 20 73 75 62 6d 69 74 74 65 64 22 20 rite submitted"
e540: 2c 63 6f 6f 6b 69 65 29 29 0a 3b 3b 3b 20 09 20 ,cookie)).;;; .
e550: 20 20 20 28 28 6f 73 73 68 6f 72 74 29 20 20 20 ((osshort)
e560: 20 60 28 23 74 20 20 22 6f 73 20 73 68 6f 72 74 `(#t "os short
e570: 20 73 75 62 6d 69 74 74 65 64 22 20 20 20 20 20 submitted"
e580: 20 2c 63 6f 6f 6b 69 65 29 29 0a 3b 3b 3b 20 09 ,cookie)).;;; .
e590: 20 20 20 20 28 28 6f 73 6c 6f 6e 67 29 20 20 20 ((oslong)
e5a0: 20 20 60 28 23 74 20 20 22 6f 73 20 6c 6f 6e 67 `(#t "os long
e5b0: 20 73 75 62 6d 69 74 74 65 64 22 20 20 20 20 20 submitted"
e5c0: 20 20 2c 63 6f 6f 6b 69 65 29 29 0a 3b 3b 3b 20 ,cookie)).;;;
e5d0: 09 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 . (else
e5e0: 20 20 20 60 28 23 66 20 20 22 75 6e 72 65 63 6f `(#f "unreco
e5f0: 67 6e 69 73 65 64 20 61 63 74 69 6f 6e 22 20 20 gnised action"
e600: 20 20 20 2c 63 74 79 70 65 29 29 29 29 29 29 29 ,ctype)))))))
e610: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 43 61 6c .;;; .;;; ;; Cal
e620: 6c 20 74 68 69 73 20 74 6f 20 73 74 61 72 74 20 l this to start
e630: 74 68 65 20 61 63 74 75 61 6c 20 73 65 72 76 65 the actual serve
e640: 72 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 r.;;; ;;.;;; ;;
e650: 73 74 61 72 74 5f 73 65 72 76 65 72 0a 3b 3b 3b start_server.;;;
e660: 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 20 20 6d 6f 64 ;;.;;; ;; mod
e670: 65 3a 20 27 0a 3b 3b 3b 20 3b 3b 20 20 20 68 61 e: '.;;; ;; ha
e680: 6e 64 6c 65 72 3a 20 70 72 6f 63 20 77 68 69 63 ndler: proc whic
e690: 68 20 74 61 6b 65 73 20 70 6b 74 72 65 63 69 65 h takes pktrecie
e6a0: 76 65 64 20 61 73 20 61 72 67 75 6d 65 6e 74 0a ved as argument.
e6b0: 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 ;;; ;;.;;; .;;;
e6c0: 28 64 65 66 69 6e 65 20 28 73 74 61 72 74 2d 73 (define (start-s
e6d0: 65 72 76 65 72 20 61 63 66 67 29 0a 3b 3b 3b 20 erver acfg).;;;
e6e0: 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 6e 20 28 (let* ((conn (
e6f0: 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 find-free-port-a
e700: 6e 64 2d 6f 70 65 6e 20 61 63 66 67 29 29 0a 3b nd-open acfg)).;
e710: 3b 3b 20 09 20 28 70 6f 72 74 20 28 61 72 65 61 ;; . (port (area
e720: 2d 70 6f 72 74 20 61 63 66 67 29 29 29 0a 3b 3b -port acfg))).;;
e730: 3b 20 20 20 20 20 28 72 70 63 3a 70 75 62 6c 69 ; (rpc:publi
e740: 73 68 2d 70 72 6f 63 65 64 75 72 65 21 0a 3b 3b sh-procedure!.;;
e750: 3b 20 20 20 20 20 20 27 64 65 6c 69 73 74 2d 64 ; 'delist-d
e760: 62 0a 3b 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 b.;;; (lamb
e770: 64 61 20 28 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 da (fname).;;;
e780: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
e790: 65 2d 64 65 6c 65 74 65 21 20 28 61 72 65 61 2d e-delete! (area-
e7a0: 64 62 73 20 61 63 66 67 29 20 66 6e 61 6d 65 29 dbs acfg) fname)
e7b0: 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 70 63 3a )).;;; (rpc:
e7c0: 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 75 72 publish-procedur
e7d0: 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 63 61 6c e!.;;; 'cal
e7e0: 6c 69 6e 67 2d 61 64 64 72 0a 3b 3b 3b 20 20 20 ling-addr.;;;
e7f0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b (lambda ().;;
e800: 3b 20 20 20 20 20 20 20 20 28 72 70 63 3a 63 75 ; (rpc:cu
e810: 72 72 65 6e 74 2d 70 65 65 72 29 29 29 0a 3b 3b rrent-peer))).;;
e820: 3b 20 20 20 20 20 28 72 70 63 3a 70 75 62 6c 69 ; (rpc:publi
e830: 73 68 2d 70 72 6f 63 65 64 75 72 65 21 0a 3b 3b sh-procedure!.;;
e840: 3b 20 20 20 20 20 20 27 70 69 6e 67 0a 3b 3b 3b ; 'ping.;;;
e850: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
e860: 28 72 65 61 6c 2d 70 69 6e 67 20 61 63 66 67 29 (real-ping acfg)
e870: 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 70 63 3a )).;;; (rpc:
e880: 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 75 72 publish-procedur
e890: 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 72 65 71 e!.;;; 'req
e8a0: 75 65 73 74 0a 3b 3b 3b 20 20 20 20 20 20 28 6c uest.;;; (l
e8b0: 61 6d 62 64 61 20 28 66 72 6f 6d 2d 61 64 64 72 ambda (from-addr
e8c0: 20 66 72 6f 6d 2d 70 6f 72 74 20 73 65 72 76 6b from-port servk
e8d0: 65 79 20 61 63 74 69 6f 6e 20 63 6f 6f 6b 69 65 ey action cookie
e8e0: 20 64 62 6e 61 6d 65 20 70 61 72 61 6d 73 29 0a dbname params).
e8f0: 3b 3b 3b 20 20 20 20 20 20 20 20 28 72 65 71 75 ;;; (requ
e900: 65 73 74 20 61 63 66 67 20 66 72 6f 6d 2d 61 64 est acfg from-ad
e910: 64 72 20 66 72 6f 6d 2d 70 6f 72 74 20 73 65 72 dr from-port ser
e920: 76 6b 65 79 20 61 63 74 69 6f 6e 20 63 6f 6f 6b vkey action cook
e930: 69 65 20 64 62 6e 61 6d 65 20 70 61 72 61 6d 73 ie dbname params
e940: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 70 63 ))).;;; (rpc
e950: 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 75 :publish-procedu
e960: 72 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 72 65 re!.;;; 're
e970: 73 70 6f 6e 73 65 0a 3b 3b 3b 20 20 20 20 20 20 sponse.;;;
e980: 28 6c 61 6d 62 64 61 20 28 63 6f 6f 6b 69 65 20 (lambda (cookie
e990: 72 65 73 2d 64 61 74 29 0a 3b 3b 3b 20 20 20 20 res-dat).;;;
e9a0: 20 20 20 20 28 64 65 6c 69 76 65 72 2d 72 65 73 (deliver-res
e9b0: 70 6f 6e 73 65 20 61 63 66 67 20 63 6f 6f 6b 69 ponse acfg cooki
e9c0: 65 20 72 65 73 2d 64 61 74 29 29 29 0a 3b 3b 3b e res-dat))).;;;
e9d0: 20 20 20 20 20 28 61 72 65 61 2d 72 65 61 64 79 (area-ready
e9e0: 2d 73 65 74 21 20 61 63 66 67 20 23 74 29 0a 3b -set! acfg #t).;
e9f0: 3b 3b 20 20 20 20 20 28 61 72 65 61 2d 63 6f 6e ;; (area-con
ea00: 6e 2d 73 65 74 21 20 61 63 66 67 20 63 6f 6e 6e n-set! acfg conn
ea10: 29 0a 3b 3b 3b 20 20 20 20 20 28 28 72 70 63 3a ).;;; ((rpc:
ea20: 6d 61 6b 65 2d 73 65 72 76 65 72 20 63 6f 6e 6e make-server conn
ea30: 29 20 23 66 29 29 29 3b 3b 20 28 28 74 63 70 2d ) #f)));; ((tcp-
ea40: 6c 69 73 74 65 6e 20 28 72 70 63 3a 64 65 66 61 listen (rpc:defa
ea50: 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 74 29 ult-server-port)
ea60: 29 20 23 74 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a ) #t).;;; .;;; .
ea70: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 6c 61 75 ;;; (define (lau
ea80: 6e 63 68 20 61 63 66 67 29 20 3b 3b 20 20 23 21 nch acfg) ;; #!
ea90: 6f 70 74 69 6f 6e 61 6c 20 28 70 72 6f 63 20 73 optional (proc s
eaa0: 74 64 2d 70 65 65 72 2d 68 61 6e 64 6c 65 72 29 td-peer-handler)
eab0: 29 0a 3b 3b 3b 20 20 20 28 70 72 69 6e 74 20 22 ).;;; (print "
eac0: 73 74 61 72 74 69 6e 67 20 6c 61 75 6e 63 68 22 starting launch"
ead0: 29 0a 3b 3b 3b 20 20 20 28 75 70 64 61 74 65 2d ).;;; (update-
eae0: 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 20 61 63 known-servers ac
eaf0: 66 67 29 20 3b 3b 20 67 6f 74 74 61 20 64 6f 20 fg) ;; gotta do
eb00: 74 68 69 73 20 6f 6e 20 65 76 65 72 79 20 73 74 this on every st
eb10: 61 72 74 20 28 74 68 75 73 20 77 68 79 20 6c 69 art (thus why li
eb20: 6d 69 74 20 6e 75 6d 62 65 72 20 6f 66 20 70 75 mit number of pu
eb30: 62 6c 69 63 69 73 65 64 20 73 65 72 76 65 72 73 blicised servers
eb40: 29 0a 3b 3b 3b 20 20 20 23 3b 28 6c 65 74 20 28 ).;;; #;(let (
eb50: 28 6f 72 69 67 69 6e 61 6c 2d 68 61 6e 64 6c 65 (original-handle
eb60: 72 20 28 63 75 72 72 65 6e 74 2d 65 78 63 65 70 r (current-excep
eb70: 74 69 6f 6e 2d 68 61 6e 64 6c 65 72 29 29 29 20 tion-handler)))
eb80: 3b 3b 20 69 73 20 74 68 0a 3b 3b 3b 20 20 20 20 ;; is th.;;;
eb90: 20 28 6c 61 6d 62 64 61 20 28 65 78 63 65 70 74 (lambda (except
eba0: 69 6f 6e 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 ion).;;; (
ebb0: 73 65 72 76 65 72 2d 65 78 69 74 2d 70 72 6f 63 server-exit-proc
ebc0: 65 64 75 72 65 29 0a 3b 3b 3b 20 20 20 20 20 20 edure).;;;
ebd0: 20 28 6f 72 69 67 69 6e 61 6c 2d 68 61 6e 64 6c (original-handl
ebe0: 65 72 20 65 78 63 65 70 74 69 6f 6e 29 29 29 0a er exception))).
ebf0: 3b 3b 3b 20 20 20 28 6f 6e 2d 65 78 69 74 20 28 ;;; (on-exit (
ec00: 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 09 20 lambda ().;;; .
ec10: 20 20 20 20 28 73 68 75 74 64 6f 77 6e 20 61 63 (shutdown ac
ec20: 66 67 29 29 29 20 3b 3b 20 28 66 69 6e 61 6c 69 fg))) ;; (finali
ec30: 7a 65 2d 61 6c 6c 2d 64 62 2d 68 61 6e 64 6c 65 ze-all-db-handle
ec40: 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 20 20 s acfg))).;;;
ec50: 3b 3b 20 73 65 74 20 75 70 20 74 68 65 20 72 70 ;; set up the rp
ec60: 63 20 68 61 6e 64 6c 65 72 0a 3b 3b 3b 20 20 20 c handler.;;;
ec70: 28 6c 65 74 2a 20 28 28 74 68 31 20 20 28 6d 61 (let* ((th1 (ma
ec80: 6b 65 2d 74 68 72 65 61 64 0a 3b 3b 3b 20 09 09 ke-thread.;;; ..
ec90: 28 6c 61 6d 62 64 61 20 28 29 28 73 74 61 72 74 (lambda ()(start
eca0: 2d 73 65 72 76 65 72 20 61 63 66 67 29 29 0a 3b -server acfg)).;
ecb0: 3b 3b 20 09 09 22 73 65 72 76 65 72 20 74 68 72 ;; .."server thr
ecc0: 65 61 64 22 29 29 0a 3b 3b 3b 20 09 20 28 74 68 ead")).;;; . (th
ecd0: 32 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 2 (make-thread
ece0: 0a 3b 3b 3b 20 09 09 20 28 6c 61 6d 62 64 61 20 .;;; .. (lambda
ecf0: 28 29 0a 3b 3b 3b 20 09 09 20 20 20 28 70 72 69 ().;;; .. (pri
ed00: 6e 74 20 22 74 68 32 20 73 74 61 72 74 69 6e 67 nt "th2 starting
ed10: 22 29 0a 3b 3b 3b 20 09 09 20 20 20 28 6c 65 74 ").;;; .. (let
ed20: 20 6c 6f 6f 70 20 28 29 0a 3b 3b 3b 20 09 09 20 loop ().;;; ..
ed30: 20 20 20 20 28 77 6f 72 6b 2d 71 75 65 75 65 2d (work-queue-
ed40: 70 72 6f 63 65 73 73 6f 72 20 61 63 66 67 29 0a processor acfg).
ed50: 3b 3b 3b 20 09 09 20 20 20 20 20 28 70 72 69 6e ;;; .. (prin
ed60: 74 20 22 77 6f 72 6b 2d 71 75 65 75 65 2d 70 72 t "work-queue-pr
ed70: 6f 63 65 73 73 6f 72 20 63 72 61 73 68 65 64 21 ocessor crashed!
ed80: 22 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 6c ").;;; .. (l
ed90: 6f 6f 70 29 29 29 0a 3b 3b 3b 20 09 09 20 22 77 oop))).;;; .. "w
eda0: 6f 72 6b 20 71 75 65 75 65 20 74 68 72 65 61 64 ork queue thread
edb0: 22 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 74 68 "))).;;; (th
edc0: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
edd0: 0a 3b 3b 3b 20 20 20 20 20 28 74 68 72 65 61 64 .;;; (thread
ede0: 2d 73 74 61 72 74 21 20 74 68 32 29 0a 3b 3b 3b -start! th2).;;;
edf0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
ee00: 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 74 68 72 ).;;; (thr
ee10: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 32 35 ead-sleep! 0.025
ee20: 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 69 66 20 ).;;; (if
ee30: 28 61 72 65 61 2d 72 65 61 64 79 20 61 63 66 67 (area-ready acfg
ee40: 29 0a 3b 3b 3b 20 09 20 20 23 74 0a 3b 3b 3b 20 ).;;; . #t.;;;
ee50: 09 20 20 28 6c 6f 6f 70 29 29 29 0a 3b 3b 3b 20 . (loop))).;;;
ee60: 20 20 20 20 3b 3b 20 61 74 74 65 6d 70 74 20 74 ;; attempt t
ee70: 6f 20 66 69 78 20 6d 79 20 61 64 64 72 65 73 73 o fix my address
ee80: 0a 3b 3b 3b 20 20 20 20 20 28 6c 65 74 2a 20 28 .;;; (let* (
ee90: 28 61 6c 6c 2d 61 64 64 72 20 28 67 65 74 2d 61 (all-addr (get-a
eea0: 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 29 29 29 ll-ips-sorted)))
eeb0: 09 20 20 20 20 20 3b 3b 20 63 6f 75 6c 64 20 75 . ;; could u
eec0: 73 65 20 28 74 63 70 2d 61 64 64 72 65 73 73 65 se (tcp-addresse
eed0: 73 20 63 6f 6e 6e 29 3f 0a 3b 3b 3b 20 20 20 20 s conn)?.;;;
eee0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 (let loop ((r
eef0: 65 6d 2d 61 64 64 72 73 20 61 6c 6c 2d 61 64 64 em-addrs all-add
ef00: 72 29 29 0a 3b 3b 3b 20 09 28 69 66 20 28 6e 75 r)).;;; .(if (nu
ef10: 6c 6c 3f 20 72 65 6d 2d 61 64 64 72 73 29 0a 3b ll? rem-addrs).;
ef20: 3b 3b 20 09 20 20 20 20 28 62 65 67 69 6e 0a 3b ;; . (begin.;
ef30: 3b 3b 20 09 20 20 20 20 20 20 28 70 72 69 6e 74 ;; . (print
ef40: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
ef50: 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 74 68 to figure out th
ef60: 65 20 69 70 20 61 64 64 72 65 73 73 20 6f 66 20 e ip address of
ef70: 6d 79 73 65 6c 66 20 61 73 20 61 20 73 65 72 76 myself as a serv
ef80: 65 72 2e 20 47 69 76 69 6e 67 20 75 70 2e 22 29 er. Giving up.")
ef90: 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 65 78 69 .;;; . (exi
efa0: 74 20 31 29 29 20 3b 3b 20 42 55 47 20 43 68 61 t 1)) ;; BUG Cha
efb0: 6e 67 65 6d 65 20 74 6f 20 72 61 69 73 69 6e 67 ngeme to raising
efc0: 20 61 6e 20 65 78 63 65 70 74 69 6f 6e 0a 3b 3b an exception.;;
efd0: 3b 20 09 09 0a 3b 3b 3b 20 09 20 20 20 20 28 6c ; ...;;; . (l
efe0: 65 74 2a 20 28 28 61 64 64 72 20 20 20 20 20 20 et* ((addr
eff0: 28 63 61 72 20 72 65 6d 2d 61 64 64 72 73 29 29 (car rem-addrs))
f000: 0a 3b 3b 3b 20 09 09 20 20 20 28 67 6f 6f 64 2d .;;; .. (good-
f010: 61 64 64 72 20 28 68 61 6e 64 6c 65 2d 65 78 63 addr (handle-exc
f020: 65 70 74 69 6f 6e 73 0a 3b 3b 3b 20 09 09 09 09 eptions.;;; ....
f030: 20 20 65 78 6e 0a 3b 3b 3b 20 09 09 09 09 20 20 exn.;;; ....
f040: 23 66 0a 3b 3b 3b 20 09 09 09 09 28 28 72 70 63 #f.;;; ....((rpc
f050: 3a 70 72 6f 63 65 64 75 72 65 20 27 63 61 6c 6c :procedure 'call
f060: 69 6e 67 2d 61 64 64 72 20 61 64 64 72 20 28 61 ing-addr addr (a
f070: 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 29 29 rea-port acfg)))
f080: 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 ))).;;; . (
f090: 69 66 20 67 6f 6f 64 2d 61 64 64 72 0a 3b 3b 3b if good-addr.;;;
f0a0: 20 09 09 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 .. (begin.;;;
f0b0: 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 47 6f .. (print "Go
f0c0: 74 20 67 6f 6f 64 2d 61 64 64 72 20 6f 66 20 22 t good-addr of "
f0d0: 20 67 6f 6f 64 2d 61 64 64 72 29 0a 3b 3b 3b 20 good-addr).;;;
f0e0: 09 09 20 20 20 20 28 61 72 65 61 2d 6d 79 61 64 .. (area-myad
f0f0: 64 72 2d 73 65 74 21 20 61 63 66 67 20 67 6f 6f dr-set! acfg goo
f100: 64 2d 61 64 64 72 29 29 0a 3b 3b 3b 20 09 09 20 d-addr)).;;; ..
f110: 20 28 6c 6f 6f 70 20 28 63 64 72 20 72 65 6d 2d (loop (cdr rem-
f120: 61 64 64 72 73 29 29 29 29 29 29 29 0a 3b 3b 3b addrs))))))).;;;
f130: 20 20 20 20 20 28 72 65 67 69 73 74 65 72 2d 6e (register-n
f140: 6f 64 65 20 61 63 66 67 20 28 61 72 65 61 2d 6d ode acfg (area-m
f150: 79 61 64 64 72 20 61 63 66 67 29 28 61 72 65 61 yaddr acfg)(area
f160: 2d 70 6f 72 74 20 61 63 66 67 29 29 0a 3b 3b 3b -port acfg)).;;;
f170: 20 20 20 20 20 28 70 72 69 6e 74 20 22 49 4e 46 (print "INF
f180: 4f 3a 20 53 65 72 76 65 72 20 73 74 61 72 74 65 O: Server starte
f190: 64 20 6f 6e 20 22 20 28 61 72 65 61 2d 6d 79 61 d on " (area-mya
f1a0: 64 64 72 20 61 63 66 67 29 20 22 3a 22 20 28 61 ddr acfg) ":" (a
f1b0: 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 29 0a rea-port acfg)).
f1c0: 3b 3b 3b 20 20 20 20 20 3b 3b 20 28 75 70 64 61 ;;; ;; (upda
f1d0: 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 te-known-servers
f1e0: 20 61 63 66 67 29 20 3b 3b 20 67 6f 74 74 61 20 acfg) ;; gotta
f1f0: 64 6f 20 74 68 69 73 20 6f 6e 20 65 76 65 72 79 do this on every
f200: 20 73 74 61 72 74 20 28 74 68 75 73 20 77 68 79 start (thus why
f210: 20 6c 69 6d 69 74 20 6e 75 6d 62 65 72 20 6f 66 limit number of
f220: 20 70 75 62 6c 69 63 69 73 65 64 20 73 65 72 76 publicised serv
f230: 65 72 73 29 0a 3b 3b 3b 20 20 20 20 20 29 29 0a ers).;;; )).
f240: 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 ;;; .;;; (define
f250: 20 28 63 6c 65 61 72 2d 73 65 72 76 65 72 2d 70 (clear-server-p
f260: 6b 74 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 28 kt acfg).;;; (
f270: 6c 65 74 20 28 28 70 6b 74 66 20 28 61 72 65 61 let ((pktf (area
f280: 2d 70 6b 74 66 69 6c 65 20 61 63 66 67 29 29 29 -pktfile acfg)))
f290: 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 70 6b 74 .;;; (if pkt
f2a0: 66 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 f (delete-file*
f2b0: 70 6b 74 66 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b pktf)))).;;; .;;
f2c0: 3b 20 28 64 65 66 69 6e 65 20 28 73 68 75 74 64 ; (define (shutd
f2d0: 6f 77 6e 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 own acfg).;;;
f2e0: 28 6c 65 74 20 28 3b 3b 28 63 6f 6e 6e 20 28 61 (let (;;(conn (a
f2f0: 72 65 61 2d 63 6f 6e 6e 20 20 20 20 61 63 66 67 rea-conn acfg
f300: 29 29 0a 3b 3b 3b 20 09 28 70 6b 74 66 20 28 61 )).;;; .(pktf (a
f310: 72 65 61 2d 70 6b 74 66 69 6c 65 20 61 63 66 67 rea-pktfile acfg
f320: 29 29 0a 3b 3b 3b 20 09 28 70 6f 72 74 20 28 61 )).;;; .(port (a
f330: 72 65 61 2d 70 6f 72 74 20 20 20 20 61 63 66 67 rea-port acfg
f340: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 ))).;;; (if
f350: 70 6b 74 66 20 28 64 65 6c 65 74 65 2d 66 69 6c pktf (delete-fil
f360: 65 2a 20 70 6b 74 66 29 29 0a 3b 3b 3b 20 20 20 e* pktf)).;;;
f370: 20 20 28 73 65 6e 64 2d 61 6c 6c 20 22 69 6d 73 (send-all "ims
f380: 68 75 74 74 69 6e 67 64 6f 77 6e 22 29 0a 3b 3b huttingdown").;;
f390: 3b 20 20 20 20 20 3b 3b 20 28 72 70 63 3a 63 6c ; ;; (rpc:cl
f3a0: 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 ose-all-connecti
f3b0: 6f 6e 73 21 29 20 3b 3b 20 64 6f 6e 27 74 20 6b ons!) ;; don't k
f3c0: 6e 6f 77 20 69 66 20 74 68 69 73 20 69 73 20 61 now if this is a
f3d0: 63 74 75 61 6c 6c 79 20 6e 65 65 64 65 64 0a 3b ctually needed.;
f3e0: 3b 3b 20 20 20 20 20 28 66 69 6e 61 6c 69 7a 65 ;; (finalize
f3f0: 2d 61 6c 6c 2d 64 62 2d 68 61 6e 64 6c 65 73 20 -all-db-handles
f400: 61 63 66 67 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b acfg))).;;; .;;;
f410: 20 28 64 65 66 69 6e 65 20 28 73 65 6e 64 2d 61 (define (send-a
f420: 6c 6c 20 6d 73 67 29 0a 3b 3b 3b 20 20 20 23 66 ll msg).;;; #f
f430: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 67 69 ).;;; .;;; ;; gi
f440: 76 65 6e 20 61 20 61 72 65 61 20 72 65 63 6f 72 ven a area recor
f450: 64 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 68 d look up all th
f460: 65 20 70 61 63 6b 65 74 73 0a 3b 3b 3b 20 3b 3b e packets.;;; ;;
f470: 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 67 65 .;;; (define (ge
f480: 74 2d 61 6c 6c 2d 73 65 72 76 65 72 2d 70 6b 74 t-all-server-pkt
f490: 73 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 28 6c s acfg).;;; (l
f4a0: 65 74 20 28 28 61 6c 6c 2d 70 6b 74 2d 66 69 6c et ((all-pkt-fil
f4b0: 65 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 28 es (glob (conc (
f4c0: 61 72 65 61 2d 70 6b 74 73 64 69 72 20 61 63 66 area-pktsdir acf
f4d0: 67 29 20 22 2f 2a 2e 70 6b 74 22 29 29 29 29 0a g) "/*.pkt")))).
f4e0: 3b 3b 3b 20 20 20 20 20 28 6d 61 70 20 28 6c 61 ;;; (map (la
f4f0: 6d 62 64 61 20 28 70 6b 74 2d 66 69 6c 65 29 0a mbda (pkt-file).
f500: 3b 3b 3b 20 09 20 20 20 28 72 65 61 64 2d 70 6b ;;; . (read-pk
f510: 74 2d 3e 61 6c 69 73 74 20 70 6b 74 2d 66 69 6c t->alist pkt-fil
f520: 65 20 70 6b 74 73 70 65 63 3a 20 2a 70 6b 74 73 e pktspec: *pkts
f530: 70 65 63 2a 29 29 0a 3b 3b 3b 20 09 20 61 6c 6c pec*)).;;; . all
f540: 2d 70 6b 74 2d 66 69 6c 65 73 29 29 29 0a 3b 3b -pkt-files))).;;
f550: 3b 20 0a 3b 3b 3b 20 23 3b 28 28 5a 20 2e 20 22 ; .;;; #;((Z . "
f560: 39 61 30 32 31 32 33 30 32 32 39 35 61 31 39 36 9a0212302295a196
f570: 31 30 64 35 37 39 36 66 63 65 30 33 37 30 66 61 10d5796fce0370fa
f580: 31 33 30 37 35 38 65 39 22 29 0a 3b 3b 3b 20 20 130758e9").;;;
f590: 20 28 70 6f 72 74 20 2e 20 22 33 34 38 32 37 22 (port . "34827"
f5a0: 29 0a 3b 3b 3b 20 20 20 28 70 69 64 20 2e 20 22 ).;;; (pid . "
f5b0: 32 38 37 34 38 22 29 0a 3b 3b 3b 20 20 20 28 68 28748").;;; (h
f5c0: 6f 73 74 6e 61 6d 65 20 2e 20 22 7a 65 75 73 22 ostname . "zeus"
f5d0: 29 0a 3b 3b 3b 20 20 20 28 54 20 2e 20 22 73 65 ).;;; (T . "se
f5e0: 72 76 65 72 22 29 0a 3b 3b 3b 20 20 20 28 44 20 rver").;;; (D
f5f0: 2e 20 22 31 35 34 39 34 32 37 30 33 32 2e 30 22 . "1549427032.0"
f600: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 23 3b 28 64 )).;;; .;;; #;(d
f610: 65 66 69 6e 65 20 28 67 65 74 2d 6d 79 2d 62 65 efine (get-my-be
f620: 73 74 2d 61 64 64 72 65 73 73 29 0a 3b 3b 3b 20 st-address).;;;
f630: 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d 6d 79 2d (let ((all-my-
f640: 61 64 64 72 65 73 73 65 73 20 28 67 65 74 2d 61 addresses (get-a
f650: 6c 6c 2d 69 70 73 29 29 29 20 3b 3b 20 28 76 65 ll-ips))) ;; (ve
f660: 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 ctor->list (host
f670: 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 info-addresses (
f680: 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e hostname->hostin
f690: 66 6f 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d fo (get-host-nam
f6a0: 65 29 29 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 e)))))).;;;
f6b0: 28 63 6f 6e 64 0a 3b 3b 3b 20 20 20 20 20 20 28 (cond.;;; (
f6c0: 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 64 (null? all-my-ad
f6d0: 64 72 65 73 73 65 73 29 0a 3b 3b 3b 20 20 20 20 dresses).;;;
f6e0: 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d (get-host-nam
f6f0: 65 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 e))
f700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f710: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
f720: 6e 6f 20 69 6e 74 65 72 66 61 63 65 73 3f 0a 3b no interfaces?.;
f730: 3b 3b 20 20 20 20 20 20 28 28 65 71 3f 20 28 6c ;; ((eq? (l
f740: 65 6e 67 74 68 20 61 6c 6c 2d 6d 79 2d 61 64 64 ength all-my-add
f750: 72 65 73 73 65 73 29 20 31 29 0a 3b 3b 3b 20 20 resses) 1).;;;
f760: 20 20 20 20 20 28 69 70 2d 3e 73 74 72 69 6e 67 (ip->string
f770: 20 28 63 61 72 20 61 6c 6c 2d 6d 79 2d 61 64 64 (car all-my-add
f780: 72 65 73 73 65 73 29 29 29 20 20 20 20 20 20 20 resses)))
f790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
f7a0: 3b 20 6f 6e 6c 79 20 6f 6e 65 20 74 6f 20 63 68 ; only one to ch
f7b0: 6f 6f 73 65 20 66 72 6f 6d 2c 20 6a 75 73 74 20 oose from, just
f7c0: 67 6f 20 77 69 74 68 20 69 74 0a 3b 3b 3b 20 20 go with it.;;;
f7d0: 20 20 20 20 28 65 6c 73 65 20 0a 3b 3b 3b 20 20 (else .;;;
f7e0: 20 20 20 20 20 28 69 70 2d 3e 73 74 72 69 6e 67 (ip->string
f7f0: 20 28 63 61 72 20 28 66 69 6c 74 65 72 20 28 6c (car (filter (l
f800: 61 6d 62 64 61 20 28 78 29 20 20 20 20 20 20 20 ambda (x)
f810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
f820: 3b 20 74 61 6b 65 20 61 6e 79 20 62 75 74 20 31 ; take any but 1
f830: 32 37 2e 0a 3b 3b 3b 20 09 09 09 09 20 28 6e 6f 27..;;; .... (no
f840: 74 20 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 t (eq? (u8vector
f850: 2d 72 65 66 20 78 20 30 29 20 31 32 37 29 29 29 -ref x 0) 127)))
f860: 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 20 61 .;;; ... a
f870: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 ll-my-addresses)
f880: 29 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 )))))).;;; .;;;
f890: 3b 3b 20 77 68 6f 61 6d 69 3f 20 49 20 61 6d 20 ;; whoami? I am
f8a0: 6d 79 20 70 6b 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b my pkt.;;; ;;.;;
f8b0: 3b 20 28 64 65 66 69 6e 65 20 28 77 68 6f 61 6d ; (define (whoam
f8c0: 69 3f 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 28 i? acfg).;;; (
f8d0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
f8e0: 65 66 61 75 6c 74 20 28 61 72 65 61 2d 68 6f 73 efault (area-hos
f8f0: 74 73 20 61 63 66 67 29 28 61 72 65 61 2d 70 6b ts acfg)(area-pk
f900: 74 69 64 20 61 63 66 67 29 20 23 66 29 29 0a 3b tid acfg) #f)).;
f910: 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d ;; .;;; ;;======
f920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f960: 0a 3b 3b 3b 20 3b 3b 20 22 43 6c 69 65 6e 74 20 .;;; ;; "Client
f970: 73 69 64 65 22 20 6f 70 65 72 61 74 69 6f 6e 73 side" operations
f980: 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;; ;;=========
f990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
f9d0: 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ; .;;; (define (
f9e0: 73 61 66 65 2d 63 61 6c 6c 20 63 61 6c 6c 2d 6b safe-call call-k
f9f0: 65 79 20 68 6f 73 74 20 70 6f 72 74 20 2e 20 70 ey host port . p
fa00: 61 72 61 6d 73 29 0a 3b 3b 3b 20 20 20 28 68 61 arams).;;; (ha
fa10: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
fa20: 3b 3b 3b 20 20 20 20 65 78 6e 0a 3b 3b 3b 20 20 ;;; exn.;;;
fa30: 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 20 20 20 (begin.;;;
fa40: 20 20 28 70 72 69 6e 74 20 22 43 61 6c 6c 20 22 (print "Call "
fa50: 20 63 61 6c 6c 2d 6b 65 79 20 22 20 74 6f 20 22 call-key " to "
fa60: 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 20 22 host ":" port "
fa70: 20 66 61 69 6c 65 64 22 29 0a 3b 3b 3b 20 20 20 failed").;;;
fa80: 20 20 20 23 66 29 0a 3b 3b 3b 20 20 20 20 28 61 #f).;;; (a
fa90: 70 70 6c 79 20 28 72 70 63 3a 70 72 6f 63 65 64 pply (rpc:proced
faa0: 75 72 65 20 63 61 6c 6c 2d 6b 65 79 20 68 6f 73 ure call-key hos
fab0: 74 20 70 6f 72 74 29 20 70 61 72 61 6d 73 29 29 t port) params))
fac0: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 3b 3b ).;;; .;;; ;; ;;
fad0: 20 63 6f 6e 76 65 72 74 20 74 6f 2f 66 72 6f 6d convert to/from
fae0: 20 73 74 72 69 6e 67 20 2f 20 73 65 78 70 72 0a string / sexpr.
faf0: 3b 3b 3b 20 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 28 ;;; ;; .;;; ;; (
fb00: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 3e define (string->
fb10: 73 65 78 70 72 20 73 74 72 29 0a 3b 3b 3b 20 3b sexpr str).;;; ;
fb20: 3b 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f ; (if (string?
fb30: 20 73 74 72 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 str).;;; ;;
fb40: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
fb50: 72 6f 6d 2d 73 74 72 69 6e 67 20 73 74 72 20 72 rom-string str r
fb60: 65 61 64 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 ead).;;; ;;
fb70: 20 20 73 74 72 29 29 0a 3b 3b 3b 20 3b 3b 20 0a str)).;;; ;; .
fb80: 3b 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;; ;; (define (
fb90: 73 65 78 70 72 2d 3e 73 74 72 69 6e 67 20 73 29 sexpr->string s)
fba0: 0a 3b 3b 3b 20 3b 3b 20 20 20 28 77 69 74 68 2d .;;; ;; (with-
fbb0: 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 output-to-string
fbc0: 20 28 6c 61 6d 62 64 61 20 28 29 28 77 72 69 74 (lambda ()(writ
fbd0: 65 20 73 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b e s)))).;;; .;;;
fbe0: 20 3b 3b 20 69 73 20 74 68 65 20 73 65 72 76 65 ;; is the serve
fbf0: 72 20 61 6c 69 76 65 3f 0a 3b 3b 3b 20 3b 3b 0a r alive?.;;; ;;.
fc00: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 70 69 6e ;;; (define (pin
fc10: 67 20 61 63 66 67 20 68 6f 73 74 20 70 6f 72 74 g acfg host port
fc20: 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 ).;;; (let* ((
fc30: 6d 79 61 64 64 72 20 20 20 20 20 28 61 72 65 61 myaddr (area
fc40: 2d 6d 79 61 64 64 72 20 61 63 66 67 29 29 0a 3b -myaddr acfg)).;
fc50: 3b 3b 20 09 20 28 6d 79 70 6f 72 74 20 20 20 20 ;; . (myport
fc60: 20 28 61 72 65 61 2d 70 6f 72 74 20 20 20 61 63 (area-port ac
fc70: 66 67 29 29 0a 3b 3b 3b 20 09 20 28 73 74 61 72 fg)).;;; . (star
fc80: 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d t-time (current-
fc90: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b milliseconds)).;
fca0: 3b 3b 20 09 20 28 72 65 73 20 20 20 20 20 20 20 ;; . (res
fcb0: 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c (if (and (equal
fcc0: 3f 20 6d 79 61 64 64 72 20 68 6f 73 74 29 0a 3b ? myaddr host).;
fcd0: 3b 3b 20 09 09 09 20 20 20 20 20 20 28 65 71 75 ;; ... (equ
fce0: 61 6c 3f 20 6d 79 70 6f 72 74 20 70 6f 72 74 29 al? myport port)
fcf0: 29 0a 3b 3b 3b 20 09 09 09 20 28 72 65 61 6c 2d ).;;; ... (real-
fd00: 70 69 6e 67 20 61 63 66 67 29 0a 3b 3b 3b 20 09 ping acfg).;;; .
fd10: 09 09 20 28 28 72 70 63 3a 70 72 6f 63 65 64 75 .. ((rpc:procedu
fd20: 72 65 20 27 70 69 6e 67 20 68 6f 73 74 20 70 6f re 'ping host po
fd30: 72 74 29 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 rt))))).;;;
fd40: 28 63 6f 6e 73 20 28 2d 20 28 63 75 72 72 65 6e (cons (- (curren
fd50: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 t-milliseconds)
fd60: 73 74 61 72 74 2d 74 69 6d 65 29 0a 3b 3b 3b 20 start-time).;;;
fd70: 09 20 20 72 65 73 29 29 29 0a 3b 3b 3b 20 0a 3b . res))).;;; .;
fd80: 3b 3b 20 3b 3b 20 72 65 74 75 72 6e 73 20 28 20 ;; ;; returns (
fd90: 69 70 61 64 64 72 20 70 6f 72 74 20 61 6c 69 73 ipaddr port alis
fda0: 74 2d 66 6e 61 6d 65 3d 3e 72 61 6e 64 6e 75 6d t-fname=>randnum
fdb0: 20 29 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ).;;; (define (
fdc0: 72 65 61 6c 2d 70 69 6e 67 20 61 63 66 67 29 0a real-ping acfg).
fdd0: 3b 3b 3b 20 20 20 60 28 2c 28 61 72 65 61 2d 6d ;;; `(,(area-m
fde0: 79 61 64 64 72 20 61 63 66 67 29 20 2c 28 61 72 yaddr acfg) ,(ar
fdf0: 65 61 2d 70 6f 72 74 20 61 63 66 67 29 20 2c 28 ea-port acfg) ,(
fe00: 67 65 74 2d 68 6f 73 74 2d 73 74 61 74 73 20 61 get-host-stats a
fe10: 63 66 67 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 cfg))).;;; .;;;
fe20: 3b 3b 20 69 73 20 74 68 65 20 73 65 72 76 65 72 ;; is the server
fe30: 20 61 6c 69 76 65 20 41 4e 44 20 74 68 65 20 71 alive AND the q
fe40: 75 65 75 65 73 20 70 72 6f 63 65 73 73 69 6e 67 ueues processing
fe50: 3f 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 23 3b 28 ?.;;; ;;.;;; #;(
fe60: 64 65 66 69 6e 65 20 28 66 75 6c 6c 2d 70 69 6e define (full-pin
fe70: 67 20 61 63 66 67 20 73 65 72 76 70 6b 74 29 0a g acfg servpkt).
fe80: 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 73 74 ;;; (let* ((st
fe90: 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e art-time (curren
fea0: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 t-milliseconds))
feb0: 0a 3b 3b 3b 20 09 20 28 72 65 73 20 20 20 20 20 .;;; . (res
fec0: 20 20 20 28 73 65 6e 64 2d 6d 65 73 73 61 67 65 (send-message
fed0: 20 61 63 66 67 20 73 65 72 76 70 6b 74 20 27 28 acfg servpkt '(
fee0: 66 75 6c 6c 2d 70 69 6e 67 29 20 27 66 75 6c 6c full-ping) 'full
fef0: 2d 70 69 6e 67 29 29 29 0a 3b 3b 3b 20 20 20 20 -ping))).;;;
ff00: 20 28 63 6f 6e 73 20 28 2d 20 28 63 75 72 72 65 (cons (- (curre
ff10: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
ff20: 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 3b 3b 3b start-time).;;;
ff30: 20 09 20 20 72 65 73 29 29 29 20 3b 3b 20 28 65 . res))) ;; (e
ff40: 71 75 61 6c 3f 20 72 65 73 20 22 67 6f 74 20 70 qual? res "got p
ff50: 69 6e 67 22 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b ing")))).;;; .;;
ff60: 3b 20 0a 3b 3b 3b 20 3b 3b 20 6c 6f 6f 6b 20 75 ; .;;; ;; look u
ff70: 70 20 61 6c 6c 20 70 6b 74 73 20 61 6e 64 20 67 p all pkts and g
ff80: 65 74 20 74 68 65 20 73 65 72 76 65 72 20 69 64 et the server id
ff90: 20 28 74 68 65 20 68 61 73 68 29 2c 20 70 6f 72 (the hash), por
ffa0: 74 2c 20 68 6f 73 74 2f 69 70 0a 3b 3b 3b 20 3b t, host/ip.;;; ;
ffb0: 3b 20 73 74 6f 72 65 20 74 68 69 73 20 69 6e 66 ; store this inf
ffc0: 6f 20 69 6e 20 61 63 66 67 0a 3b 3b 3b 20 3b 3b o in acfg.;;; ;;
ffd0: 20 72 65 74 75 72 6e 20 74 68 65 20 6e 75 6d 62 return the numb
ffe0: 65 72 20 6f 66 20 72 65 73 70 6f 6e 73 69 76 65 er of responsive
fff0: 20 73 65 72 76 65 72 73 20 66 6f 75 6e 64 0a 3b servers found.;
10000 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 44 4f 20 ;; ;;.;;; ;; DO
10010 4e 4f 54 20 56 45 52 49 46 59 20 54 48 41 54 20 NOT VERIFY THAT
10020 54 48 45 20 53 45 52 56 45 52 20 49 53 20 41 4c THE SERVER IS AL
10030 49 56 45 20 48 45 52 45 2e 20 54 68 69 73 20 69 IVE HERE. This i
10040 73 20 63 61 6c 6c 65 64 20 61 74 20 74 69 6d 65 s called at time
10050 73 20 77 68 65 72 65 20 74 68 65 20 63 75 72 72 s where the curr
10060 65 6e 74 20 73 65 72 76 65 72 20 69 73 20 6e 6f ent server is no
10070 74 20 79 65 74 20 61 6c 69 76 65 20 61 6e 64 20 t yet alive and
10080 63 61 6e 6e 6f 74 20 70 69 6e 67 20 69 74 73 65 cannot ping itse
10090 6c 66 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 lf.;;; ;;.;;; (d
100a0 65 66 69 6e 65 20 28 75 70 64 61 74 65 2d 6b 6e efine (update-kn
100b0 6f 77 6e 2d 73 65 72 76 65 72 73 20 61 63 66 67 own-servers acfg
100c0 29 0a 3b 3b 3b 20 20 20 3b 3b 20 72 65 61 64 6c ).;;; ;; readl
100d0 6c 20 61 6c 6c 20 70 6b 74 73 0a 3b 3b 3b 20 20 l all pkts.;;;
100e0 20 3b 3b 20 66 6f 72 65 61 63 68 20 70 6b 74 3b ;; foreach pkt;
100f0 20 69 66 20 69 74 20 69 73 6e 27 74 20 6d 65 20 if it isn't me
10100 70 69 6e 67 20 74 68 65 20 73 65 72 76 65 72 3b ping the server;
10110 20 69 66 20 61 6c 69 76 65 2c 20 61 64 64 20 74 if alive, add t
10120 6f 20 68 6f 73 74 73 20 68 61 73 68 2c 20 65 6c o hosts hash, el
10130 73 65 20 72 6d 20 74 68 65 20 70 6b 74 0a 3b 3b se rm the pkt.;;
10140 3b 20 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 ; (let* ((star
10150 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d t-time (current-
10160 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b milliseconds)).;
10170 3b 3b 20 09 20 28 61 6c 6c 2d 70 6b 74 73 20 20 ;; . (all-pkts
10180 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
10190 65 73 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 61 es.;;; .. (a
101a0 70 70 65 6e 64 20 28 67 65 74 2d 61 6c 6c 2d 73 ppend (get-all-s
101b0 65 72 76 65 72 2d 70 6b 74 73 20 61 63 66 67 29 erver-pkts acfg)
101c0 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 68 61 .;;; ... (ha
101d0 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 sh-table-values
101e0 28 61 72 65 61 2d 68 6f 73 74 73 20 61 63 66 67 (area-hosts acfg
101f0 29 29 29 29 29 0a 3b 3b 3b 20 09 20 28 68 6f 73 ))))).;;; . (hos
10200 74 73 68 61 73 68 20 28 61 72 65 61 2d 68 6f 73 tshash (area-hos
10210 74 73 20 61 63 66 67 29 29 0a 3b 3b 3b 20 09 20 ts acfg)).;;; .
10220 28 6d 79 2d 69 64 20 20 20 20 20 28 61 72 65 61 (my-id (area
10230 2d 70 6b 74 69 64 20 61 63 66 67 29 29 0a 3b 3b -pktid acfg)).;;
10240 3b 20 09 20 28 70 6b 74 73 64 69 72 20 20 20 28 ; . (pktsdir (
10250 61 72 65 61 2d 70 6b 74 73 64 69 72 20 61 63 66 area-pktsdir acf
10260 67 29 29 20 3b 3b 20 6e 65 65 64 65 64 20 74 6f g)) ;; needed to
10270 20 72 65 6d 6f 76 65 20 70 6b 74 73 20 66 72 6f remove pkts fro
10280 6d 20 6e 6f 6e 2d 72 65 73 70 6f 6e 73 69 76 65 m non-responsive
10290 20 73 65 72 76 65 72 73 0a 3b 3b 3b 20 09 20 28 servers.;;; . (
102a0 6e 75 6d 73 72 76 73 20 20 20 30 29 0a 3b 3b 3b numsrvs 0).;;;
102b0 20 09 20 28 64 65 6c 70 6b 74 20 20 20 20 28 6c . (delpkt (l
102c0 61 6d 62 64 61 20 28 70 6b 74 73 64 69 72 20 73 ambda (pktsdir s
102d0 69 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 id).;;; ..
102e0 28 70 72 69 6e 74 20 22 63 6c 65 61 72 69 6e 67 (print "clearing
102f0 20 6f 75 74 20 73 65 72 76 65 72 20 22 20 73 69 out server " si
10300 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 28 d).;;; .. (
10310 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 28 63 6f delete-file* (co
10320 6e 63 20 70 6b 74 73 64 69 72 20 22 2f 22 20 73 nc pktsdir "/" s
10330 69 64 20 22 2e 70 6b 74 22 29 29 0a 3b 3b 3b 20 id ".pkt")).;;;
10340 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 .. (hash-ta
10350 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 6f 73 74 ble-delete! host
10360 73 68 61 73 68 20 73 69 64 29 29 29 29 0a 3b 3b shash sid)))).;;
10370 3b 20 20 20 20 20 28 61 72 65 61 2d 6c 61 73 74 ; (area-last
10380 2d 73 72 76 75 70 2d 73 65 74 21 20 61 63 66 67 -srvup-set! acfg
10390 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
103a0 73 29 29 0a 3b 3b 3b 20 20 20 20 20 28 66 6f 72 s)).;;; (for
103b0 2d 65 61 63 68 0a 3b 3b 3b 20 20 20 20 20 20 28 -each.;;; (
103c0 6c 61 6d 62 64 61 20 28 73 65 72 76 70 6b 74 29 lambda (servpkt)
103d0 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 69 66 20 .;;; (if
103e0 28 6c 69 73 74 3f 20 73 65 72 76 70 6b 74 29 0a (list? servpkt).
103f0 3b 3b 3b 20 09 20 20 20 3b 3b 20 28 70 70 20 73 ;;; . ;; (pp s
10400 65 72 76 70 6b 74 29 0a 3b 3b 3b 20 09 20 20 20 ervpkt).;;; .
10410 28 6c 65 74 2a 20 28 28 73 68 6f 73 74 20 28 61 (let* ((shost (a
10420 6c 69 73 74 2d 72 65 66 20 27 69 70 61 64 64 72 list-ref 'ipaddr
10430 20 73 65 72 76 70 6b 74 29 29 0a 3b 3b 3b 20 09 servpkt)).;;; .
10440 09 20 20 28 73 70 6f 72 74 20 28 61 6e 79 2d 3e . (sport (any->
10450 6e 75 6d 62 65 72 20 28 61 6c 69 73 74 2d 72 65 number (alist-re
10460 66 20 27 70 6f 72 74 20 73 65 72 76 70 6b 74 29 f 'port servpkt)
10470 29 29 0a 3b 3b 3b 20 09 09 20 20 28 72 65 73 20 )).;;; .. (res
10480 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
10490 69 6f 6e 73 0a 3b 3b 3b 20 09 09 09 20 20 65 78 ions.;;; ... ex
104a0 6e 0a 3b 3b 3b 20 09 09 09 20 20 28 62 65 67 69 n.;;; ... (begi
104b0 6e 0a 3b 3b 3b 20 09 09 09 20 20 20 20 3b 3b 20 n.;;; ... ;;
104c0 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a 20 62 61 (print "INFO: ba
104d0 64 20 73 65 72 76 65 72 20 6f 6e 20 22 20 73 68 d server on " sh
104e0 6f 73 74 20 22 3a 22 20 73 70 6f 72 74 29 0a 3b ost ":" sport).;
104f0 3b 3b 20 09 09 09 20 20 20 20 23 66 29 0a 3b 3b ;; ... #f).;;
10500 3b 20 09 09 09 20 20 28 70 69 6e 67 20 61 63 66 ; ... (ping acf
10510 67 20 73 68 6f 73 74 20 73 70 6f 72 74 29 29 29 g shost sport)))
10520 0a 3b 3b 3b 20 09 09 20 20 28 73 69 64 20 20 20 .;;; .. (sid
10530 28 61 6c 69 73 74 2d 72 65 66 20 27 5a 20 73 65 (alist-ref 'Z se
10540 72 76 70 6b 74 29 29 20 3b 3b 20 5a 20 63 6f 64 rvpkt)) ;; Z cod
10550 65 20 69 73 20 6f 75 72 20 6e 61 6d 65 20 66 6f e is our name fo
10560 72 20 74 68 65 20 73 65 72 76 65 72 0a 3b 3b 3b r the server.;;;
10570 20 09 09 20 20 28 75 72 6c 20 20 20 28 63 6f 6e .. (url (con
10580 63 20 73 68 6f 73 74 20 22 3a 22 20 73 70 6f 72 c shost ":" spor
10590 74 29 29 0a 3b 3b 3b 20 09 09 20 20 29 0a 3b 3b t)).;;; .. ).;;
105a0 3b 20 09 20 20 20 20 20 23 3b 28 69 66 20 28 6f ; . #;(if (o
105b0 72 20 28 6e 6f 74 20 72 65 73 29 0a 3b 3b 3b 20 r (not res).;;;
105c0 09 09 20 20 20 20 20 28 6e 75 6c 6c 3f 20 72 65 .. (null? re
105d0 73 29 29 0a 3b 3b 3b 20 09 09 20 28 62 65 67 69 s)).;;; .. (begi
105e0 6e 0a 3b 3b 3b 20 09 09 20 20 20 28 70 72 69 6e n.;;; .. (prin
105f0 74 20 22 53 54 52 41 4e 47 45 3a 20 70 69 6e 67 t "STRANGE: ping
10600 20 6f 66 20 22 20 75 72 6c 20 22 20 67 61 76 65 of " url " gave
10610 20 22 20 72 65 73 29 29 29 0a 3b 3b 3b 20 09 20 " res))).;;; .
10620 20 20 20 20 0a 3b 3b 3b 20 09 20 20 20 20 20 3b .;;; . ;
10630 3b 20 28 70 72 69 6e 74 20 22 47 6f 74 20 22 20 ; (print "Got "
10640 72 65 73 20 22 20 66 72 6f 6d 20 22 20 73 68 6f res " from " sho
10650 73 74 20 22 3a 22 20 73 70 6f 72 74 29 0a 3b 3b st ":" sport).;;
10660 3b 20 09 20 20 20 20 20 28 6d 61 74 63 68 20 72 ; . (match r
10670 65 73 0a 3b 3b 3b 20 09 09 20 20 20 20 28 28 71 es.;;; .. ((q
10680 64 75 72 61 74 69 6f 6e 20 2e 20 70 61 79 6c 6f duration . paylo
10690 61 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b ad).;;; .. ;
106a0 3b 20 28 70 72 69 6e 74 20 22 53 65 72 76 65 72 ; (print "Server
106b0 20 70 6b 74 3a 22 20 28 61 6c 69 73 74 2d 72 65 pkt:" (alist-re
106c0 66 20 27 69 70 61 64 64 72 20 73 65 72 76 70 6b f 'ipaddr servpk
106d0 74 29 20 22 3a 22 20 28 61 6c 69 73 74 2d 72 65 t) ":" (alist-re
106e0 66 20 27 70 6f 72 74 20 73 65 72 76 70 6b 74 29 f 'port servpkt)
106f0 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 20 .;;; .. ;;
10700 20 20 20 20 20 20 28 69 66 20 70 61 79 6c 6f 61 (if payloa
10710 64 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 d.;;; .. ;;
10720 20 20 20 20 20 20 20 20 20 20 20 22 53 75 63 63 "Succ
10730 65 73 73 22 20 22 46 61 69 6c 22 29 29 0a 3b 3b ess" "Fail")).;;
10740 3b 20 09 09 20 20 20 20 20 28 6d 61 74 63 68 20 ; .. (match
10750 70 61 79 6c 6f 61 64 0a 3b 3b 3b 20 09 09 09 20 payload.;;; ...
10760 20 20 20 28 28 68 6f 73 74 20 70 6f 72 74 20 73 ((host port s
10770 74 61 74 73 29 0a 3b 3b 3b 20 09 09 09 20 20 20 tats).;;; ...
10780 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 46 72 6f ;; (print "Fro
10790 6d 20 22 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 m " host ":" por
107a0 74 20 22 20 67 6f 74 20 73 74 61 74 73 3a 20 22 t " got stats: "
107b0 20 73 74 61 74 73 29 0a 3b 3b 3b 20 09 09 09 20 stats).;;; ...
107c0 20 20 20 20 28 69 66 20 28 61 6e 64 20 68 6f 73 (if (and hos
107d0 74 20 70 6f 72 74 20 73 74 61 74 73 29 0a 3b 3b t port stats).;;
107e0 3b 20 09 09 09 09 20 28 6c 65 74 20 28 28 75 72 ; .... (let ((ur
107f0 6c 20 28 63 6f 6e 63 20 68 6f 73 74 20 22 3a 22 l (conc host ":"
10800 20 70 6f 72 74 29 29 29 0a 3b 3b 3b 20 09 09 09 port))).;;; ...
10810 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
10820 73 65 74 21 20 68 6f 73 74 73 68 61 73 68 20 73 set! hostshash s
10830 69 64 20 73 65 72 76 70 6b 74 29 0a 3b 3b 3b 20 id servpkt).;;;
10840 09 09 09 09 20 20 20 3b 3b 20 73 74 6f 72 65 20 .... ;; store
10850 62 61 73 65 64 20 6f 6e 20 68 6f 73 74 3a 70 6f based on host:po
10860 72 74 0a 3b 3b 3b 20 09 09 09 09 20 20 20 28 68 rt.;;; .... (h
10870 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
10880 61 72 65 61 2d 68 6f 73 74 73 74 61 74 73 20 61 area-hoststats a
10890 63 66 67 29 20 73 69 64 20 73 74 61 74 73 29 29 cfg) sid stats))
108a0 0a 3b 3b 3b 20 09 09 09 09 20 28 70 72 69 6e 74 .;;; .... (print
108b0 20 22 6d 69 73 73 69 6e 67 20 64 61 74 61 20 66 "missing data f
108c0 72 6f 6d 20 74 68 65 20 73 65 72 76 65 72 2c 20 rom the server,
108d0 6e 6f 74 20 73 75 72 65 20 77 68 61 74 20 74 68 not sure what th
108e0 61 74 20 6d 65 61 6e 73 21 22 29 29 0a 3b 3b 3b at means!")).;;;
108f0 20 09 09 09 20 20 20 20 20 28 73 65 74 21 20 6e ... (set! n
10900 75 6d 73 72 76 73 20 28 2b 20 6e 75 6d 73 72 76 umsrvs (+ numsrv
10910 73 20 31 29 29 29 0a 3b 3b 3b 20 09 09 09 20 20 s 1))).;;; ...
10920 20 20 28 23 66 0a 3b 3b 3b 20 09 09 09 20 20 20 (#f.;;; ...
10930 20 20 28 70 72 69 6e 74 20 22 52 65 6d 6f 76 69 (print "Removi
10940 6e 67 20 70 6b 74 20 22 20 73 69 64 20 22 20 64 ng pkt " sid " d
10950 75 65 20 74 6f 20 23 66 20 66 72 6f 6d 20 73 65 ue to #f from se
10960 72 76 65 72 20 6f 72 20 66 61 69 6c 65 64 20 70 rver or failed p
10970 69 6e 67 22 29 0a 3b 3b 3b 20 09 09 09 20 20 20 ing").;;; ...
10980 20 20 28 64 65 6c 70 6b 74 20 70 6b 74 73 64 69 (delpkt pktsdi
10990 72 20 73 69 64 29 29 0a 3b 3b 3b 20 09 09 09 20 r sid)).;;; ...
109a0 20 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 09 09 (else.;;; ...
109b0 20 20 20 20 20 28 70 72 69 6e 74 20 22 47 6f 74 (print "Got
109c0 20 22 29 28 70 70 20 72 65 73 29 28 70 72 69 6e ")(pp res)(prin
109d0 74 20 22 20 66 72 6f 6d 20 73 65 72 76 65 72 20 t " from server
109e0 22 29 28 70 70 20 73 65 72 76 70 6b 74 29 20 22 ")(pp servpkt) "
109f0 20 62 75 74 20 72 65 73 70 6f 6e 73 65 20 64 69 but response di
10a00 64 20 6e 6f 74 20 6d 61 74 63 68 20 28 23 66 2f d not match (#f/
10a10 23 74 20 2e 20 6d 73 67 29 22 29 29 29 0a 3b 3b #t . msg)"))).;;
10a20 3b 20 09 09 20 20 20 20 28 65 6c 73 65 0a 3b 3b ; .. (else.;;
10a30 3b 20 09 09 20 20 20 20 20 3b 3b 20 68 65 72 65 ; .. ;; here
10a40 20 77 65 20 64 65 6c 65 74 65 20 74 68 65 20 70 we delete the p
10a50 6b 74 20 2d 20 63 61 6e 27 74 20 72 65 61 63 68 kt - can't reach
10a60 20 74 68 65 20 73 65 72 76 65 72 2c 20 72 65 6d the server, rem
10a70 6f 76 65 20 69 74 0a 3b 3b 3b 20 09 09 20 20 20 ove it.;;; ..
10a80 20 20 3b 3b 20 68 6f 77 65 76 65 72 20 74 68 69 ;; however thi
10a90 73 20 6c 6f 67 69 63 20 69 73 20 69 6e 61 64 65 s logic is inade
10aa0 71 75 61 74 65 2e 20 77 65 20 73 68 6f 75 6c 64 quate. we should
10ab0 20 6d 61 72 6b 20 74 68 65 20 73 65 72 76 65 72 mark the server
10ac0 20 61 73 20 63 68 65 63 6b 65 64 0a 3b 3b 3b 20 as checked.;;;
10ad0 09 09 20 20 20 20 20 3b 3b 20 61 6e 64 20 6e 6f .. ;; and no
10ae0 74 20 67 6f 6f 64 2c 20 69 66 20 69 74 20 68 61 t good, if it ha
10af0 70 70 65 6e 73 20 61 20 73 65 63 6f 6e 64 20 74 ppens a second t
10b00 69 6d 65 20 2d 20 74 68 65 6e 20 72 65 6d 6f 76 ime - then remov
10b10 65 20 74 68 65 20 70 6b 74 0a 3b 3b 3b 20 09 09 e the pkt.;;; ..
10b20 20 20 20 20 20 3b 3b 20 6f 72 20 73 6f 6d 65 74 ;; or somet
10b30 68 69 6e 67 20 73 69 6d 69 6c 61 72 2e 20 49 2e hing similar. I.
10b40 65 2e 20 64 6f 6e 27 74 20 62 65 20 74 6f 6f 20 e. don't be too
10b50 71 75 69 63 6b 20 74 6f 20 61 73 73 75 6d 65 20 quick to assume
10b60 74 68 65 20 73 65 72 76 65 72 20 69 73 20 77 65 the server is we
10b70 64 67 65 64 20 6f 72 20 64 65 61 64 0a 3b 3b 3b dged or dead.;;;
10b80 20 09 09 20 20 20 20 20 3b 3b 20 63 6f 75 6c 64 .. ;; could
10b90 20 62 65 20 69 74 20 69 73 20 73 69 6d 70 6c 79 be it is simply
10ba0 20 74 6f 6f 20 62 75 73 79 20 74 6f 20 72 65 70 too busy to rep
10bb0 6c 79 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 6c ly.;;; .. (l
10bc0 65 74 20 28 28 62 61 64 2d 70 69 6e 67 73 20 28 et ((bad-pings (
10bd0 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
10be0 65 66 61 75 6c 74 20 28 61 72 65 61 2d 68 65 61 efault (area-hea
10bf0 6c 74 68 20 61 63 66 67 29 20 75 72 6c 20 30 29 lth acfg) url 0)
10c00 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 )).;;; ..
10c10 28 69 66 20 28 3e 20 62 61 64 2d 70 69 6e 67 73 (if (> bad-pings
10c20 20 31 29 20 3b 3b 20 74 77 6f 20 62 61 64 20 70 1) ;; two bad p
10c30 69 6e 67 73 20 2d 20 72 65 6d 6f 76 65 20 70 6b ings - remove pk
10c40 74 0a 3b 3b 3b 20 09 09 09 20 20 20 28 62 65 67 t.;;; ... (beg
10c50 69 6e 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 in.;;; ... (
10c60 70 72 69 6e 74 20 22 49 4e 46 4f 3a 20 22 20 62 print "INFO: " b
10c70 61 64 2d 70 69 6e 67 73 20 22 20 62 61 64 20 72 ad-pings " bad r
10c80 65 73 70 6f 6e 73 65 73 20 66 72 6f 6d 20 22 20 esponses from "
10c90 75 72 6c 20 22 2c 20 64 65 6c 65 74 69 6e 67 20 url ", deleting
10ca0 70 6b 74 20 22 20 73 69 64 29 0a 3b 3b 3b 20 09 pkt " sid).;;; .
10cb0 09 09 20 20 20 20 20 28 64 65 6c 70 6b 74 20 70 .. (delpkt p
10cc0 6b 74 73 64 69 72 20 73 69 64 29 29 0a 3b 3b 3b ktsdir sid)).;;;
10cd0 20 09 09 09 20 20 20 28 62 65 67 69 6e 0a 3b 3b ... (begin.;;
10ce0 3b 20 09 09 09 20 20 20 20 20 28 70 72 69 6e 74 ; ... (print
10cf0 20 22 49 4e 46 4f 3a 20 22 20 62 61 64 2d 70 69 "INFO: " bad-pi
10d00 6e 67 73 20 22 20 62 61 64 20 72 65 73 70 6f 6e ngs " bad respon
10d10 73 65 73 20 66 72 6f 6d 20 22 20 73 68 6f 73 74 ses from " shost
10d20 20 22 3a 22 20 73 70 6f 72 74 20 22 20 6e 6f 74 ":" sport " not
10d30 20 64 65 6c 65 74 69 6e 67 20 70 6b 74 20 79 65 deleting pkt ye
10d40 74 22 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 t").;;; ...
10d50 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
10d60 20 28 61 72 65 61 2d 68 65 61 6c 74 68 20 61 63 (area-health ac
10d70 66 67 29 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 fg).;;; .....
10d80 20 20 20 75 72 6c 0a 3b 3b 3b 20 09 09 09 09 09 url.;;; .....
10d90 20 20 20 20 20 20 28 2b 20 28 68 61 73 68 2d 74 (+ (hash-t
10da0 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
10db0 20 28 61 72 65 61 2d 68 65 61 6c 74 68 20 61 63 (area-health ac
10dc0 66 67 29 20 75 72 6c 20 30 29 20 31 29 29 0a 3b fg) url 0) 1)).;
10dd0 3b 3b 20 09 09 09 20 20 20 20 20 29 29 0a 3b 3b ;; ... )).;;
10de0 3b 20 09 09 20 20 20 20 20 20 20 29 29 29 29 0a ; .. )))).
10df0 3b 3b 3b 20 09 20 20 20 3b 3b 20 73 65 72 76 70 ;;; . ;; servp
10e00 6b 74 20 69 73 20 6e 6f 74 20 61 63 74 75 61 6c kt is not actual
10e10 6c 79 20 61 20 70 6b 74 3f 0a 3b 3b 3b 20 09 20 ly a pkt?.;;; .
10e20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 (begin.;;; .
10e30 20 20 20 28 70 72 69 6e 74 20 22 42 61 64 20 70 (print "Bad p
10e40 6b 74 20 22 20 73 65 72 76 70 6b 74 29 29 29 29 kt " servpkt))))
10e50 0a 3b 3b 3b 20 20 20 20 20 20 61 6c 6c 2d 70 6b .;;; all-pk
10e60 74 73 29 0a 3b 3b 3b 20 20 20 20 20 28 73 64 62 ts).;;; (sdb
10e70 67 3e 20 22 75 70 64 61 74 65 2d 6b 6e 6f 77 6e g> "update-known
10e80 2d 73 65 72 76 65 72 73 22 20 22 65 6e 64 22 20 -servers" "end"
10e90 73 74 61 72 74 2d 74 69 6d 65 20 23 66 20 23 66 start-time #f #f
10ea0 20 22 20 66 6f 75 6e 64 20 22 20 6e 75 6d 73 72 " found " numsr
10eb0 76 73 0a 3b 3b 3b 20 09 20 20 20 22 20 73 65 72 vs.;;; . " ser
10ec0 76 65 72 73 2c 20 70 6b 74 73 3a 20 22 20 28 6d vers, pkts: " (m
10ed0 61 70 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 3b ap (lambda (p).;
10ee0 3b 3b 20 09 09 09 09 20 20 20 20 20 28 61 6c 69 ;; .... (ali
10ef0 73 74 2d 72 65 66 20 27 5a 20 70 29 29 0a 3b 3b st-ref 'Z p)).;;
10f00 3b 20 09 09 09 09 20 20 20 61 6c 6c 2d 70 6b 74 ; .... all-pkt
10f10 73 29 29 0a 3b 3b 3b 20 20 20 20 20 6e 75 6d 73 s)).;;; nums
10f20 72 76 73 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 rvs)).;;; .;;; (
10f30 64 65 66 73 74 72 75 63 74 20 73 72 76 73 74 61 defstruct srvsta
10f40 74 0a 3b 3b 3b 20 20 20 28 6e 75 6d 66 69 6c 65 t.;;; (numfile
10f50 73 20 30 29 20 20 20 3b 3b 20 6e 75 6d 62 65 72 s 0) ;; number
10f60 20 6f 66 20 64 62 20 66 69 6c 65 73 20 68 61 6e of db files han
10f70 64 6c 65 64 20 62 79 20 74 68 69 73 20 73 65 72 dled by this ser
10f80 76 65 72 20 2d 20 73 75 62 74 72 61 63 74 20 31 ver - subtract 1
10f90 20 66 6f 72 20 74 68 65 20 64 62 20 62 65 69 6e for the db bein
10fa0 67 20 63 75 72 72 65 6e 74 6c 79 20 6c 6f 6f 6b g currently look
10fb0 65 64 20 61 74 0a 3b 3b 3b 20 20 20 28 72 61 6e ed at.;;; (ran
10fc0 64 6e 75 6d 20 20 23 66 29 20 20 3b 3b 20 74 69 dnum #f) ;; ti
10fd0 65 20 62 72 65 61 6b 65 72 20 6e 75 6d 62 65 72 e breaker number
10fe0 20 61 73 73 69 67 6e 65 64 20 74 6f 20 62 79 20 assigned to by
10ff0 74 68 65 20 73 65 72 76 65 72 20 69 74 73 65 6c the server itsel
11000 66 20 2d 20 61 70 70 6c 69 65 73 20 6f 6e 6c 79 f - applies only
11010 20 74 6f 20 74 68 65 20 64 62 20 75 6e 64 65 72 to the db under
11020 20 63 6f 6e 73 69 64 65 72 61 74 69 6f 6e 0a 3b consideration.;
11030 3b 3b 20 20 20 28 70 6b 74 20 20 20 20 20 20 23 ;; (pkt #
11040 66 29 29 20 3b 3b 20 74 68 65 20 73 65 72 76 65 f)) ;; the serve
11050 72 20 70 6b 74 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b r pkt.;;; .;;; ;
11060 3b 28 64 65 66 69 6e 65 20 28 73 72 76 2d 3e 73 ;(define (srv->s
11070 72 76 73 74 61 74 20 73 72 76 70 6b 74 29 0a 3b rvstat srvpkt).;
11080 3b 3b 20 20 20 0a 3b 3b 3b 20 3b 3b 20 47 65 74 ;; .;;; ;; Get
11090 20 74 68 65 20 73 65 72 76 65 72 20 62 65 73 74 the server best
110a0 20 66 6f 72 20 67 69 76 65 6e 20 64 62 6e 61 6d for given dbnam
110b0 65 20 61 6e 64 20 6b 65 79 0a 3b 3b 3b 20 3b 3b e and key.;;; ;;
110c0 0a 3b 3b 3b 20 3b 3b 20 20 20 4e 4f 54 45 3a 20 .;;; ;; NOTE:
110d0 6b 65 79 20 69 73 20 6e 6f 74 20 63 75 72 72 65 key is not curre
110e0 6e 74 6c 79 20 75 73 65 64 2e 20 54 68 65 20 6b ntly used. The k
110f0 65 79 20 70 6f 69 6e 74 73 20 74 6f 20 74 68 65 ey points to the
11100 20 6b 69 6e 64 20 6f 66 20 71 75 65 72 79 2c 20 kind of query,
11110 74 68 69 73 20 6d 61 79 20 62 65 20 75 73 65 66 this may be usef
11120 75 6c 20 66 6f 72 20 64 69 72 65 63 74 69 6e 67 ul for directing
11130 20 72 65 61 64 2d 6f 6e 6c 79 20 71 75 65 72 69 read-only queri
11140 65 73 2e 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 es..;;; ;;.;;; (
11150 64 65 66 69 6e 65 20 28 67 65 74 2d 62 65 73 74 define (get-best
11160 2d 73 65 72 76 65 72 20 61 63 66 67 20 64 62 6e -server acfg dbn
11170 61 6d 65 20 6b 65 79 29 0a 3b 3b 3b 20 20 20 28 ame key).;;; (
11180 6c 65 74 2a 20 28 3b 3b 20 28 73 65 72 76 65 72 let* (;; (server
11190 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 s (hash-table-va
111a0 6c 75 65 73 20 28 61 72 65 61 2d 68 6f 73 74 73 lues (area-hosts
111b0 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 09 20 28 acfg))).;;; . (
111c0 73 65 72 76 65 72 73 20 20 20 20 20 28 61 72 65 servers (are
111d0 61 2d 68 6f 73 74 73 20 61 63 66 67 29 29 0a 3b a-hosts acfg)).;
111e0 3b 3b 20 09 20 28 73 6b 65 79 73 20 20 20 20 20 ;; . (skeys
111f0 20 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 (sort (hash-ta
11200 62 6c 65 2d 6b 65 79 73 20 73 65 72 76 65 72 73 ble-keys servers
11210 29 20 73 74 72 69 6e 67 3e 3d 3f 29 29 20 3b 3b ) string>=?)) ;;
11220 20 61 20 73 74 61 62 6c 65 20 6c 69 73 74 69 6e a stable listin
11230 67 0a 3b 3b 3b 20 09 20 28 73 74 61 72 74 2d 74 g.;;; . (start-t
11240 69 6d 65 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 ime (current-mi
11250 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b lliseconds)).;;;
11260 20 09 20 28 73 72 76 73 74 61 74 73 20 20 20 20 . (srvstats
11270 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
11280 29 29 20 20 3b 3b 20 73 72 76 69 64 20 3d 3e 20 )) ;; srvid =>
11290 73 72 76 73 74 61 74 0a 3b 3b 3b 20 09 20 28 75 srvstat.;;; . (u
112a0 72 6c 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 rl (conc
112b0 20 28 61 72 65 61 2d 6d 79 61 64 64 72 20 61 63 (area-myaddr ac
112c0 66 67 29 20 22 3a 22 20 28 61 72 65 61 2d 70 6f fg) ":" (area-po
112d0 72 74 20 61 63 66 67 29 29 29 29 0a 3b 3b 3b 20 rt acfg)))).;;;
112e0 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 73 ;; (print "s
112f0 63 6f 72 65 73 20 66 6f 72 20 22 20 64 62 6e 61 cores for " dbna
11300 6d 65 20 22 3a 20 22 20 28 6d 61 70 20 28 6c 61 me ": " (map (la
11310 6d 62 64 61 20 28 6b 29 28 63 6f 6e 73 20 6b 20 mbda (k)(cons k
11320 28 63 61 6c 63 2d 73 65 72 76 65 72 2d 73 63 6f (calc-server-sco
11330 72 65 20 61 63 66 67 20 64 62 6e 61 6d 65 20 6b re acfg dbname k
11340 29 29 29 20 73 6b 65 79 73 29 29 0a 3b 3b 3b 20 ))) skeys)).;;;
11350 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 73 (if (null? s
11360 6b 65 79 73 29 0a 3b 3b 3b 20 09 28 69 66 20 28 keys).;;; .(if (
11370 3e 20 28 75 70 64 61 74 65 2d 6b 6e 6f 77 6e 2d > (update-known-
11380 73 65 72 76 65 72 73 20 61 63 66 67 29 20 30 29 servers acfg) 0)
11390 0a 3b 3b 3b 20 09 20 20 20 20 28 67 65 74 2d 62 .;;; . (get-b
113a0 65 73 74 2d 73 65 72 76 65 72 20 61 63 66 67 20 est-server acfg
113b0 64 62 6e 61 6d 65 20 6b 65 79 29 20 3b 3b 20 73 dbname key) ;; s
113c0 6f 6d 65 20 72 69 73 6b 20 6f 66 20 69 6e 66 69 ome risk of infi
113d0 6e 69 74 65 20 6c 6f 6f 70 20 68 65 72 65 2c 20 nite loop here,
113e0 54 4f 44 4f 20 61 64 64 20 74 72 79 20 63 6f 75 TODO add try cou
113f0 6e 74 65 72 0a 3b 3b 3b 20 09 20 20 20 20 28 62 nter.;;; . (b
11400 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 20 20 20 20 egin.;;; .
11410 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 6e (print "ERROR: n
11420 6f 20 73 65 72 76 65 72 20 66 6f 75 6e 64 21 22 o server found!"
11430 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 69 73 20 ) ;; since this
11440 70 72 6f 63 65 73 73 20 69 73 20 61 6c 73 6f 20 process is also
11450 61 20 73 65 72 76 65 72 20 74 68 69 73 20 73 68 a server this sh
11460 6f 75 6c 64 20 6e 65 76 65 72 20 68 61 70 70 65 ould never happe
11470 6e 0a 3b 3b 3b 20 09 20 20 20 20 20 20 23 66 29 n.;;; . #f)
11480 29 0a 3b 3b 3b 20 09 28 62 65 67 69 6e 0a 3b 3b ).;;; .(begin.;;
11490 3b 20 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ; . ;; (print "
114a0 69 6e 20 67 65 74 2d 62 65 73 74 2d 73 65 72 76 in get-best-serv
114b0 65 72 20 77 69 74 68 20 73 6b 65 79 73 3d 22 20 er with skeys="
114c0 73 6b 65 79 73 29 0a 3b 3b 3b 20 09 20 20 28 69 skeys).;;; . (i
114d0 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 f (> (- (current
114e0 2d 73 65 63 6f 6e 64 73 29 20 28 61 72 65 61 2d -seconds) (area-
114f0 6c 61 73 74 2d 73 72 76 75 70 20 61 63 66 67 29 last-srvup acfg)
11500 29 20 31 30 29 0a 3b 3b 3b 20 09 20 20 20 20 20 ) 10).;;; .
11510 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 28 75 (begin.;;; ..(u
11520 70 64 61 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 pdate-known-serv
11530 65 72 73 20 61 63 66 67 29 0a 3b 3b 3b 20 09 09 ers acfg).;;; ..
11540 28 73 64 62 67 3e 20 22 67 65 74 2d 62 65 73 74 (sdbg> "get-best
11550 2d 73 65 72 76 65 72 22 20 22 75 70 64 61 74 65 -server" "update
11560 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 22 20 -known-servers"
11570 73 74 61 72 74 2d 74 69 6d 65 20 23 66 20 23 66 start-time #f #f
11580 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 09 20 20 ))).;;; .;;; .
11590 3b 3b 20 66 6f 72 20 65 61 63 68 20 73 65 72 76 ;; for each serv
115a0 65 72 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 6c er look at the l
115b0 69 73 74 20 6f 66 20 64 62 66 69 6c 65 73 2c 20 ist of dbfiles,
115c0 74 6f 74 61 6c 20 6e 75 6d 62 65 72 20 6f 66 20 total number of
115d0 64 62 73 20 62 65 69 6e 67 20 68 61 6e 64 6c 65 dbs being handle
115e0 64 0a 3b 3b 3b 20 09 20 20 3b 3b 20 61 6e 64 20 d.;;; . ;; and
115f0 74 68 65 20 72 61 6e 64 20 6e 75 6d 62 65 72 2c the rand number,
11600 20 73 61 76 65 20 74 68 65 20 62 65 73 74 20 68 save the best h
11610 6f 73 74 0a 3b 3b 3b 20 09 20 20 3b 3b 20 61 6c ost.;;; . ;; al
11620 73 6f 20 64 6f 20 61 20 64 65 6c 69 73 74 2d 64 so do a delist-d
11630 62 20 66 6f 72 20 65 61 63 68 20 73 65 72 76 65 b for each serve
11640 72 20 64 62 66 69 6c 65 20 6e 6f 74 20 75 73 65 r dbfile not use
11650 64 0a 3b 3b 3b 20 09 20 20 28 6c 65 74 2a 20 28 d.;;; . (let* (
11660 28 62 65 73 74 2d 73 65 72 76 65 72 20 20 20 20 (best-server
11670 20 20 20 23 66 29 0a 3b 3b 3b 20 09 09 20 28 73 #f).;;; .. (s
11680 65 72 76 65 72 73 2d 74 6f 2d 64 65 6c 69 73 74 ervers-to-delist
11690 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
116a0 65 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 66 e))).;;; . (f
116b0 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 09 20 20 20 or-each.;;; .
116c0 20 20 28 6c 61 6d 62 64 61 20 28 73 72 76 69 64 (lambda (srvid
116d0 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 6c ).;;; . (l
116e0 65 74 2a 20 28 28 73 65 72 76 65 72 20 20 20 20 et* ((server
116f0 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
11700 64 65 66 61 75 6c 74 20 73 65 72 76 65 72 73 20 default servers
11710 73 72 76 69 64 20 23 66 29 29 0a 3b 3b 3b 20 09 srvid #f)).;;; .
11720 09 20 20 20 20 20 20 28 73 74 61 74 73 20 20 20 . (stats
11730 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
11740 66 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d f/default (area-
11750 68 6f 73 74 73 74 61 74 73 20 61 63 66 67 29 20 hoststats acfg)
11760 73 72 76 69 64 20 27 28 28 29 29 29 29 29 0a 3b srvid '(())))).;
11770 3b 3b 20 09 09 20 3b 3b 20 28 70 72 69 6e 74 20 ;; .. ;; (print
11780 22 73 74 61 74 73 3a 20 22 20 73 74 61 74 73 29 "stats: " stats)
11790 0a 3b 3b 3b 20 20 09 09 20 28 69 66 20 73 65 72 .;;; .. (if ser
117a0 76 65 72 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 ver.;;; .. (
117b0 6c 65 74 2a 20 28 28 64 62 77 65 69 67 68 74 73 let* ((dbweights
117c0 20 28 63 61 72 20 73 74 61 74 73 29 29 0a 3b 3b (car stats)).;;
117d0 3b 20 09 09 09 20 20 20 20 28 73 72 76 6c 6f 61 ; ... (srvloa
117e0 64 20 20 20 28 6c 65 6e 67 74 68 20 28 66 69 6c d (length (fil
117f0 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 ter (lambda (x)(
11800 6e 6f 74 20 28 65 71 75 61 6c 3f 20 64 62 6e 61 not (equal? dbna
11810 6d 65 20 28 63 61 72 20 78 29 29 29 29 20 64 62 me (car x)))) db
11820 77 65 69 67 68 74 73 29 29 29 0a 3b 3b 3b 20 09 weights))).;;; .
11830 09 09 20 20 20 20 28 64 62 72 65 63 20 20 20 20 .. (dbrec
11840 20 28 61 6c 69 73 74 2d 72 65 66 20 64 62 6e 61 (alist-ref dbna
11850 6d 65 20 64 62 77 65 69 67 68 74 73 20 65 71 75 me dbweights equ
11860 61 6c 3f 29 29 20 20 3b 3b 20 67 65 74 20 74 68 al?)) ;; get th
11870 65 20 70 61 69 72 20 77 69 74 68 20 66 6e 61 6d e pair with fnam
11880 65 20 2e 20 72 61 6e 64 73 63 6f 72 65 0a 3b 3b e . randscore.;;
11890 3b 20 09 09 09 20 20 20 20 28 72 61 6e 64 6e 75 ; ... (randnu
118a0 6d 20 20 20 28 69 66 20 64 62 72 65 63 0a 3b 3b m (if dbrec.;;
118b0 3b 20 09 09 09 09 09 20 20 20 64 62 72 65 63 20 ; ..... dbrec
118c0 3b 3b 20 28 63 64 72 20 64 62 72 65 63 29 0a 3b ;; (cdr dbrec).;
118d0 3b 3b 20 09 09 09 09 09 20 20 20 30 29 29 29 0a ;; ..... 0))).
118e0 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 28 68 61 ;;; .. (ha
118f0 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 72 sh-table-set! sr
11900 76 73 74 61 74 73 20 73 72 76 69 64 20 28 6d 61 vstats srvid (ma
11910 6b 65 2d 73 72 76 73 74 61 74 20 6e 75 6d 66 69 ke-srvstat numfi
11920 6c 65 73 3a 20 73 72 76 6c 6f 61 64 20 72 61 6e les: srvload ran
11930 64 6e 75 6d 3a 20 72 61 6e 64 6e 75 6d 20 70 6b dnum: randnum pk
11940 74 3a 20 73 65 72 76 65 72 29 29 29 29 29 29 0a t: server)))))).
11950 3b 3b 3b 20 09 20 20 20 20 20 73 6b 65 79 73 29 ;;; . skeys)
11960 0a 3b 3b 3b 20 09 20 20 20 20 0a 3b 3b 3b 20 09 .;;; . .;;; .
11970 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f 72 74 (let* ((sort
11980 65 64 20 20 20 20 28 73 6f 72 74 20 28 68 61 73 ed (sort (has
11990 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 73 h-table-values s
119a0 72 76 73 74 61 74 73 29 20 0a 3b 3b 3b 20 09 09 rvstats) .;;; ..
119b0 09 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 .. (lambda (a
119c0 20 62 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 b).;;; ....
119d0 20 20 28 6c 65 74 20 28 28 6e 75 6d 66 69 6c 65 (let ((numfile
119e0 73 2d 61 20 28 73 72 76 73 74 61 74 2d 6e 75 6d s-a (srvstat-num
119f0 66 69 6c 65 73 20 61 29 29 0a 3b 3b 3b 20 09 09 files a)).;;; ..
11a00 09 09 09 20 20 20 20 28 6e 75 6d 66 69 6c 65 73 ... (numfiles
11a10 2d 62 20 28 73 72 76 73 74 61 74 2d 6e 75 6d 66 -b (srvstat-numf
11a20 69 6c 65 73 20 62 29 29 0a 3b 3b 3b 20 09 09 09 iles b)).;;; ...
11a30 09 09 20 20 20 20 28 72 61 6e 64 6e 75 6d 2d 61 .. (randnum-a
11a40 20 20 28 73 72 76 73 74 61 74 2d 72 61 6e 64 6e (srvstat-randn
11a50 75 6d 20 61 29 29 0a 3b 3b 3b 20 09 09 09 09 09 um a)).;;; .....
11a60 20 20 20 20 28 72 61 6e 64 6e 75 6d 2d 62 20 20 (randnum-b
11a70 28 73 72 76 73 74 61 74 2d 72 61 6e 64 6e 75 6d (srvstat-randnum
11a80 20 62 29 29 29 0a 3b 3b 3b 20 09 09 09 09 09 28 b))).;;; .....(
11a90 69 66 20 28 3c 20 6e 75 6d 66 69 6c 65 73 2d 61 if (< numfiles-a
11aa0 20 6e 75 6d 66 69 6c 65 73 2d 62 29 20 3b 3b 20 numfiles-b) ;;
11ab0 4e 6f 74 65 2c 20 49 20 64 6f 6e 27 74 20 74 68 Note, I don't th
11ac0 69 6e 6b 20 61 64 64 69 6e 67 20 61 6e 20 6f 66 ink adding an of
11ad0 66 73 65 74 20 77 6f 72 6b 73 20 68 65 72 65 2e fset works here.
11ae0 20 47 6f 61 6c 20 77 61 73 20 6f 6e 6c 79 20 6d Goal was only m
11af0 6f 76 65 20 66 69 6c 65 20 68 61 6e 64 6c 69 6e ove file handlin
11b00 67 20 74 6f 20 61 20 64 69 66 66 65 72 65 6e 74 g to a different
11b10 20 73 65 72 76 65 72 20 69 66 20 69 74 20 68 61 server if it ha
11b20 73 20 32 20 6c 65 73 73 0a 3b 3b 3b 20 09 09 09 s 2 less.;;; ...
11b30 09 09 20 20 20 20 23 74 0a 3b 3b 3b 20 09 09 09 .. #t.;;; ...
11b40 09 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 .. (if (and (
11b50 65 71 75 61 6c 3f 20 6e 75 6d 66 69 6c 65 73 2d equal? numfiles-
11b60 61 20 6e 75 6d 66 69 6c 65 73 2d 62 29 0a 3b 3b a numfiles-b).;;
11b70 3b 20 09 09 09 09 09 09 20 20 20 20 20 28 3c 20 ; ...... (<
11b80 72 61 6e 64 6e 75 6d 2d 61 20 72 61 6e 64 6e 75 randnum-a randnu
11b90 6d 2d 62 29 29 0a 3b 3b 3b 20 09 09 09 09 09 09 m-b)).;;; ......
11ba0 23 74 0a 3b 3b 3b 20 09 09 09 09 09 09 23 66 29 #t.;;; ......#f)
11bb0 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 ))))).;;; .. (
11bc0 62 65 73 74 20 20 20 20 20 20 28 69 66 20 28 6e best (if (n
11bd0 75 6c 6c 3f 20 73 6f 72 74 65 64 29 0a 3b 3b 3b ull? sorted).;;;
11be0 20 09 09 09 09 20 20 28 62 65 67 69 6e 0a 3b 3b .... (begin.;;
11bf0 3b 20 09 09 09 09 20 20 20 20 28 70 72 69 6e 74 ; .... (print
11c00 20 22 45 52 52 4f 52 3a 20 73 68 6f 75 6c 64 20 "ERROR: should
11c10 6e 65 76 65 72 20 62 65 20 6e 75 6c 6c 20 64 75 never be null du
11c20 65 20 74 6f 20 73 65 6c 66 20 61 73 20 73 65 72 e to self as ser
11c30 76 65 72 2e 22 29 0a 3b 3b 3b 20 09 09 09 09 20 ver.").;;; ....
11c40 20 20 20 23 66 29 0a 3b 3b 3b 20 09 09 09 09 20 #f).;;; ....
11c50 20 28 73 72 76 73 74 61 74 2d 70 6b 74 20 28 63 (srvstat-pkt (c
11c60 61 72 20 73 6f 72 74 65 64 29 29 29 29 29 0a 3b ar sorted))))).;
11c70 3b 3b 20 09 20 20 20 20 20 20 23 3b 28 70 72 69 ;; . #;(pri
11c80 6e 74 20 22 53 45 52 56 45 52 28 22 20 75 72 6c nt "SERVER(" url
11c90 20 22 29 3a 20 22 20 64 62 6e 61 6d 65 20 22 3a "): " dbname ":
11ca0 20 22 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 " (map (lambda
11cb0 28 73 72 76 29 0a 3b 3b 3b 20 09 09 09 09 09 09 (srv).;;; ......
11cc0 09 20 20 20 20 28 6c 65 74 20 28 28 70 20 28 73 . (let ((p (s
11cd0 72 76 73 74 61 74 2d 70 6b 74 20 73 72 76 29 29 rvstat-pkt srv))
11ce0 29 0a 3b 3b 3b 20 09 09 09 09 09 09 09 20 20 20 ).;;; .......
11cf0 20 20 20 28 63 6f 6e 63 20 28 61 6c 69 73 74 2d (conc (alist-
11d00 72 65 66 20 27 69 70 61 64 64 72 20 70 29 20 22 ref 'ipaddr p) "
11d10 3a 22 20 28 61 6c 69 73 74 2d 72 65 66 20 27 70 :" (alist-ref 'p
11d20 6f 72 74 20 70 29 0a 3b 3b 3b 20 09 09 09 09 09 ort p).;;; .....
11d30 09 09 09 20 20 20 20 22 28 22 20 28 73 72 76 73 ... "(" (srvs
11d40 74 61 74 2d 6e 75 6d 66 69 6c 65 73 20 73 72 76 tat-numfiles srv
11d50 29 22 2c 22 28 73 72 76 73 74 61 74 2d 72 61 6e )","(srvstat-ran
11d60 64 6e 75 6d 20 73 72 76 29 22 29 22 29 29 29 0a dnum srv)")"))).
11d70 3b 3b 3b 20 09 09 09 09 09 09 09 20 20 20 20 73 ;;; ....... s
11d80 6f 72 74 65 64 29 29 0a 3b 3b 3b 20 09 20 20 20 orted)).;;; .
11d90 20 20 20 62 65 73 74 29 29 29 29 29 29 0a 3b 3b best)))))).;;
11da0 3b 20 20 20 20 20 0a 3b 3b 3b 20 20 20 20 20 3b ; .;;; ;
11db0 3b 20 73 65 6e 64 20 6f 75 74 20 61 6e 20 22 49 ; send out an "I
11dc0 27 6d 20 61 62 6f 75 74 20 74 6f 20 65 78 69 74 'm about to exit
11dd0 20 6e 6f 74 69 63 65 20 74 6f 20 61 6c 6c 20 6b notice to all k
11de0 6e 6f 77 6e 20 73 65 72 76 65 72 73 22 0a 3b 3b nown servers".;;
11df0 3b 20 20 20 20 20 3b 3b 0a 3b 3b 3b 20 28 64 65 ; ;;.;;; (de
11e00 66 69 6e 65 20 28 64 65 61 74 68 2d 69 6d 6d 69 fine (death-immi
11e10 6e 65 6e 74 20 61 63 66 67 29 0a 3b 3b 3b 20 20 nent acfg).;;;
11e20 20 27 28 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b '()).;;; .;;; ;
11e30 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
11e40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11e50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11e60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11e70 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 55 =======.;;; ;; U
11e80 20 4c 20 45 20 58 20 20 2d 20 20 54 20 48 20 45 L E X - T H E
11e90 20 20 20 49 20 4e 20 54 20 45 20 52 20 45 20 53 I N T E R E S
11ea0 20 54 20 49 20 4e 20 47 20 20 20 53 20 54 20 55 T I N G S T U
11eb0 20 46 20 46 20 21 20 21 0a 3b 3b 3b 20 3b 3b 3d F F ! !.;;; ;;=
11ec0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11ed0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11ee0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11ef0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f00 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b =====.;;; .;;; ;
11f10 3b 20 72 65 67 69 73 74 65 72 20 61 20 68 61 6e ; register a han
11f20 64 6c 65 72 0a 3b 3b 3b 20 3b 3b 20 20 20 4e 4f dler.;;; ;; NO
11f30 54 45 53 3a 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 TES:.;;; ;;
11f40 64 62 69 6e 69 74 73 71 6c 20 20 20 69 73 20 72 dbinitsql is r
11f50 65 73 65 72 76 65 64 20 66 6f 72 20 61 20 6c 69 eserved for a li
11f60 73 74 20 6f 66 20 73 71 6c 20 73 74 61 74 65 6d st of sql statem
11f70 65 6e 74 73 20 66 6f 72 20 69 6e 69 74 69 61 6c ents for initial
11f80 69 7a 69 6e 67 20 74 68 65 20 64 62 0a 3b 3b 3b izing the db.;;;
11f90 20 3b 3b 20 20 20 20 20 64 62 69 6e 69 74 66 6e ;; dbinitfn
11fa0 20 20 20 20 69 73 20 72 65 73 65 72 76 65 64 20 is reserved
11fb0 66 6f 72 20 61 20 64 62 20 69 6e 69 74 20 66 75 for a db init fu
11fc0 6e 63 74 69 6f 6e 2c 20 69 66 20 65 78 69 73 74 nction, if exist
11fd0 73 20 63 61 6c 6c 65 64 20 61 66 74 65 72 20 64 s called after d
11fe0 62 69 6e 69 74 73 71 6c 0a 3b 3b 3b 20 3b 3b 20 binitsql.;;; ;;
11ff0 20 20 20 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 .;;; (define
12000 20 28 72 65 67 69 73 74 65 72 20 61 63 66 67 20 (register acfg
12010 6b 65 79 20 6f 62 6a 20 23 21 6f 70 74 69 6f 6e key obj #!option
12020 61 6c 20 28 63 74 79 70 65 20 27 64 62 77 72 69 al (ctype 'dbwri
12030 74 65 29 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 te)).;;; (let
12040 28 28 68 74 20 28 61 72 65 61 2d 72 74 61 62 6c ((ht (area-rtabl
12050 65 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 20 20 e acfg))).;;;
12060 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
12070 65 2d 65 78 69 73 74 73 3f 20 68 74 20 6b 65 79 e-exists? ht key
12080 29 0a 3b 3b 3b 20 09 28 70 72 69 6e 74 20 22 57 ).;;; .(print "W
12090 41 52 4e 49 4e 47 3a 20 72 65 64 65 66 69 6e 69 ARNING: redefini
120a0 74 69 6f 6e 20 6f 66 20 65 6e 74 72 79 20 22 20 tion of entry "
120b0 6b 65 79 29 29 0a 3b 3b 3b 20 20 20 20 20 28 68 key)).;;; (h
120c0 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 ash-table-set! h
120d0 74 20 6b 65 79 20 28 6d 61 6b 65 2d 63 61 6c 6c t key (make-call
120e0 64 61 74 20 6f 62 6a 3a 20 6f 62 6a 20 63 74 79 dat obj: obj cty
120f0 70 65 3a 20 63 74 79 70 65 29 29 29 29 0a 3b 3b pe: ctype)))).;;
12100 3b 20 0a 3b 3b 3b 20 3b 3b 20 75 73 61 67 65 3a ; .;;; ;; usage:
12110 20 72 65 67 69 73 74 65 72 2d 62 61 74 63 68 20 register-batch
12120 61 63 66 67 20 27 28 28 6b 65 79 31 20 2e 20 73 acfg '((key1 . s
12130 71 6c 31 29 20 28 6b 65 79 32 20 2e 20 73 71 6c ql1) (key2 . sql
12140 32 29 20 2e 2e 2e 20 29 0a 3b 3b 3b 20 3b 3b 20 2) ... ).;;; ;;
12150 4e 42 2f 2f 20 6f 62 6a 20 69 73 20 6f 66 74 65 NB// obj is ofte
12160 6e 20 61 6e 20 73 71 6c 20 71 75 65 72 79 0a 3b n an sql query.;
12170 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e ;; ;;.;;; (defin
12180 65 20 28 72 65 67 69 73 74 65 72 2d 62 61 74 63 e (register-batc
12190 68 20 61 63 66 67 20 63 74 79 70 65 20 64 61 74 h acfg ctype dat
121a0 61 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 28 28 a).;;; (let ((
121b0 68 74 20 28 61 72 65 61 2d 72 74 61 62 6c 65 20 ht (area-rtable
121c0 61 63 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 acfg))).;;;
121d0 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 64 61 (map (lambda (da
121e0 74 29 0a 3b 3b 3b 20 09 20 20 20 28 68 61 73 68 t).;;; . (hash
121f0 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 28 -table-set! ht (
12200 63 61 72 20 64 61 74 29 28 6d 61 6b 65 2d 63 61 car dat)(make-ca
12210 6c 6c 64 61 74 20 6f 62 6a 3a 20 28 63 64 72 20 lldat obj: (cdr
12220 64 61 74 29 20 63 74 79 70 65 3a 20 63 74 79 70 dat) ctype: ctyp
12230 65 29 29 29 0a 3b 3b 3b 20 09 20 64 61 74 61 29 e))).;;; . data)
12240 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 )).;;; .;;; (def
12250 69 6e 65 20 28 69 6e 69 74 69 61 6c 69 7a 65 2d ine (initialize-
12260 61 72 65 61 2d 63 61 6c 6c 73 2d 66 72 6f 6d 2d area-calls-from-
12270 73 70 65 63 66 69 6c 65 20 61 72 65 61 20 73 70 specfile area sp
12280 65 63 66 69 6c 65 29 0a 3b 3b 3b 20 20 20 28 6c ecfile).;;; (l
12290 65 74 2a 20 28 28 63 61 6c 6c 73 70 65 63 20 28 et* ((callspec (
122a0 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
122b0 66 69 6c 65 20 73 70 65 63 66 69 6c 65 20 72 65 file specfile re
122c0 61 64 20 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 ad ))).;;; (
122d0 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
122e0 20 28 67 72 6f 75 70 29 0a 3b 3b 3b 20 20 20 20 (group).;;;
122f0 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 (re
12300 67 69 73 74 65 72 2d 62 61 74 63 68 0a 3b 3b 3b gister-batch.;;;
12310 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12320 20 20 61 72 65 61 0a 3b 3b 3b 20 20 20 20 20 20 area.;;;
12330 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 72 (car
12340 20 67 72 6f 75 70 29 0a 3b 3b 3b 20 20 20 20 20 group).;;;
12350 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 64 (cd
12360 72 20 67 72 6f 75 70 29 29 29 0a 3b 3b 3b 20 20 r group))).;;;
12370 20 20 20 20 20 20 20 20 20 20 20 20 20 63 61 6c cal
12380 6c 73 70 65 63 29 29 29 0a 3b 3b 3b 20 0a 3b 3b lspec))).;;; .;;
12390 3b 20 3b 3b 20 67 65 74 2d 72 65 6e 74 72 79 0a ; ;; get-rentry.
123a0 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 ;;; ;;.;;; (defi
123b0 6e 65 20 28 67 65 74 2d 72 65 6e 74 72 79 20 61 ne (get-rentry a
123c0 63 66 67 20 6b 65 79 29 0a 3b 3b 3b 20 20 20 28 cfg key).;;; (
123d0 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
123e0 65 66 61 75 6c 74 20 28 61 72 65 61 2d 72 74 61 efault (area-rta
123f0 62 6c 65 20 61 63 66 67 29 20 6b 65 79 20 23 66 ble acfg) key #f
12400 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 )).;;; .;;; (def
12410 69 6e 65 20 28 67 65 74 2d 72 73 71 6c 20 61 63 ine (get-rsql ac
12420 66 67 20 6b 65 79 29 0a 3b 3b 3b 20 20 20 28 6c fg key).;;; (l
12430 65 74 20 28 28 63 64 61 74 20 28 67 65 74 2d 72 et ((cdat (get-r
12440 65 6e 74 72 79 20 61 63 66 67 20 6b 65 79 29 29 entry acfg key))
12450 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 63 64 ).;;; (if cd
12460 61 74 0a 3b 3b 3b 20 09 28 63 61 6c 6c 64 61 74 at.;;; .(calldat
12470 2d 6f 62 6a 20 63 64 61 74 29 0a 3b 3b 3b 20 09 -obj cdat).;;; .
12480 23 66 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a #f))).;;; .;;; .
12490 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 62 6c 6f 63 ;;; .;;; ;; bloc
124a0 6b 69 6e 67 20 63 61 6c 6c 3a 0a 3b 3b 3b 20 3b king call:.;;; ;
124b0 3b 20 20 20 20 63 6c 69 65 6e 74 20 20 20 20 20 ; client
124c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
124d0 20 20 20 20 73 65 72 76 65 72 0a 3b 3b 3b 20 3b server.;;; ;
124e0 3b 20 20 20 20 2d 2d 2d 2d 2d 2d 20 20 20 20 20 ; ------
124f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12500 20 20 20 20 2d 2d 2d 2d 2d 2d 0a 3b 3b 3b 20 3b ------.;;; ;
12510 3b 20 20 20 20 63 61 6c 6c 28 29 0a 3b 3b 3b 20 ; call().;;;
12520 3b 3b 20 20 20 20 73 65 6e 64 2d 6d 65 73 73 61 ;; send-messa
12530 67 65 28 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 6e ge().;;; ;; n
12540 6d 73 67 2d 73 65 6e 64 28 29 0a 3b 3b 3b 20 3b msg-send().;;; ;
12550 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
12560 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12570 20 20 20 20 6e 6d 73 67 2d 72 65 63 65 69 76 65 nmsg-receive
12580 28 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 20 20 ().;;; ;;
12590 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
125a0 20 20 20 20 20 20 20 20 20 20 20 20 6e 6d 73 67 nmsg
125b0 2d 72 65 73 70 6f 6e 64 28 61 63 6b 2c 63 6f 6f -respond(ack,coo
125c0 6b 69 65 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 61 kie).;;; ;; a
125d0 63 6b 2c 20 63 6f 6f 6b 69 65 0a 3b 3b 3b 20 3b ck, cookie.;;; ;
125e0 3b 20 20 20 20 6d 62 6f 78 2d 74 68 72 65 61 64 ; mbox-thread
125f0 2d 77 61 69 74 28 63 6f 6f 6b 69 65 29 0a 3b 3b -wait(cookie).;;
12600 3b 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ; ;;
12610 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12620 20 20 20 20 20 20 20 6e 6d 73 67 2d 73 65 6e 64 nmsg-send
12630 28 63 6c 69 65 6e 74 2c 63 6f 6f 6b 69 65 2c 72 (client,cookie,r
12640 65 73 75 6c 74 29 0a 3b 3b 3b 20 3b 3b 20 20 20 esult).;;; ;;
12650 20 20 20 20 20 6e 6d 73 67 2d 72 65 73 70 6f 6e nmsg-respon
12660 64 28 61 63 6b 29 0a 3b 3b 3b 20 3b 3b 20 20 20 d(ack).;;; ;;
12670 20 20 20 20 20 72 65 74 75 72 6e 20 72 65 73 75 return resu
12680 6c 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b 3b lt.;;; ;;.;;; ;;
12690 20 72 65 73 65 72 76 65 64 20 61 63 74 69 6f 6e reserved action
126a0 3a 0a 3b 3b 3b 20 3b 3b 20 20 20 20 27 69 6d 6d :.;;; ;; 'imm
126b0 65 64 69 61 74 65 0a 3b 3b 3b 20 3b 3b 20 20 20 ediate.;;; ;;
126c0 20 27 64 62 69 6e 69 74 73 71 6c 0a 3b 3b 3b 20 'dbinitsql.;;;
126d0 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;.;;; (define (
126e0 63 61 6c 6c 20 61 63 66 67 20 64 62 6e 61 6d 65 call acfg dbname
126f0 20 61 63 74 69 6f 6e 20 70 61 72 61 6d 73 20 23 action params #
12700 21 6f 70 74 69 6f 6e 61 6c 20 28 63 6f 75 6e 74 !optional (count
12710 20 30 29 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 0)).;;; (let*
12720 20 28 28 63 61 6c 6c 2d 73 74 61 72 74 2d 74 69 ((call-start-ti
12730 6d 65 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d me (current-
12740 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b milliseconds)).;
12750 3b 3b 20 09 20 28 73 72 76 20 20 20 20 20 20 20 ;; . (srv
12760 20 20 20 20 20 20 20 20 20 20 28 67 65 74 2d 62 (get-b
12770 65 73 74 2d 73 65 72 76 65 72 20 61 63 66 67 20 est-server acfg
12780 64 62 6e 61 6d 65 20 61 63 74 69 6f 6e 29 29 0a dbname action)).
12790 3b 3b 3b 20 09 20 28 70 6f 73 74 2d 67 65 74 2d ;;; . (post-get-
127a0 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
127b0 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
127c0 29 29 0a 3b 3b 3b 20 09 20 28 72 64 61 74 20 20 )).;;; . (rdat
127d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
127e0 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
127f0 66 61 75 6c 74 20 28 61 72 65 61 2d 72 74 61 62 fault (area-rtab
12800 6c 65 20 61 63 66 67 29 20 61 63 74 69 6f 6e 20 le acfg) action
12810 23 66 29 29 0a 3b 3b 3b 20 09 20 28 6d 79 69 64 #f)).;;; . (myid
12820 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12830 28 74 72 69 6d 2d 70 6b 74 69 64 20 28 61 72 65 (trim-pktid (are
12840 61 2d 70 6b 74 69 64 20 61 63 66 67 29 29 29 0a a-pktid acfg))).
12850 3b 3b 3b 20 09 20 28 73 72 76 69 64 20 20 20 20 ;;; . (srvid
12860 20 20 20 20 20 20 20 20 20 20 20 28 74 72 69 6d (trim
12870 2d 70 6b 74 69 64 20 28 61 6c 69 73 74 2d 72 65 -pktid (alist-re
12880 66 20 27 5a 20 73 72 76 29 29 29 0a 3b 3b 3b 20 f 'Z srv))).;;;
12890 09 20 28 63 6f 6f 6b 69 65 20 20 20 20 20 20 20 . (cookie
128a0 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 63 6f 6f (make-coo
128b0 6b 69 65 20 6d 79 69 64 29 29 29 0a 3b 3b 3b 20 kie myid))).;;;
128c0 20 20 20 20 28 73 64 62 67 3e 20 22 63 61 6c 6c (sdbg> "call
128d0 22 20 22 67 65 74 2d 62 65 73 74 2d 73 65 72 76 " "get-best-serv
128e0 65 72 22 20 63 61 6c 6c 2d 73 74 61 72 74 2d 74 er" call-start-t
128f0 69 6d 65 20 23 66 20 63 61 6c 6c 2d 73 74 61 72 ime #f call-star
12900 74 2d 74 69 6d 65 20 22 20 66 72 6f 6d 3a 20 22 t-time " from: "
12910 20 6d 79 69 64 20 22 20 74 6f 20 73 65 72 76 65 myid " to serve
12920 72 3a 20 22 20 73 72 76 69 64 20 22 20 66 6f 72 r: " srvid " for
12930 20 22 20 64 62 6e 61 6d 65 20 22 20 61 63 74 69 " dbname " acti
12940 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 20 70 on: " action " p
12950 61 72 61 6d 73 3a 20 22 20 70 61 72 61 6d 73 20 arams: " params
12960 22 20 72 64 61 74 3a 20 22 20 72 64 61 74 29 0a " rdat: " rdat).
12970 3b 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 ;;; (print "
12980 49 4e 46 4f 3a 20 63 61 6c 6c 20 74 6f 20 22 20 INFO: call to "
12990 28 61 6c 69 73 74 2d 72 65 66 20 27 69 70 61 64 (alist-ref 'ipad
129a0 64 72 20 73 72 76 29 20 22 3a 22 20 28 61 6c 69 dr srv) ":" (ali
129b0 73 74 2d 72 65 66 20 27 70 6f 72 74 20 73 72 76 st-ref 'port srv
129c0 29 20 22 20 66 72 6f 6d 20 22 20 28 61 72 65 61 ) " from " (area
129d0 2d 6d 79 61 64 64 72 20 61 63 66 67 29 20 22 3a -myaddr acfg) ":
129e0 22 20 28 61 72 65 61 2d 70 6f 72 74 20 61 63 66 " (area-port acf
129f0 67 29 20 22 20 66 6f 72 20 22 20 64 62 6e 61 6d g) " for " dbnam
12a00 65 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 28 e).;;; (if (
12a10 61 6e 64 20 73 72 76 20 72 64 61 74 29 20 3b 3b and srv rdat) ;;
12a20 20 6e 65 65 64 20 62 6f 74 68 20 74 6f 20 64 69 need both to di
12a30 73 70 61 74 63 68 20 61 20 72 65 71 75 65 73 74 spatch a request
12a40 0a 3b 3b 3b 20 09 28 6c 65 74 2a 20 28 28 72 69 .;;; .(let* ((ri
12a50 70 61 64 64 72 20 20 28 61 6c 69 73 74 2d 72 65 paddr (alist-re
12a60 66 20 27 69 70 61 64 64 72 20 73 72 76 29 29 0a f 'ipaddr srv)).
12a70 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 72 73 72 ;;; . (rsr
12a80 76 69 64 20 20 20 28 61 6c 69 73 74 2d 72 65 66 vid (alist-ref
12a90 20 27 5a 20 73 72 76 29 29 0a 3b 3b 3b 20 09 20 'Z srv)).;;; .
12aa0 20 20 20 20 20 20 28 72 70 6f 72 74 20 20 20 20 (rport
12ab0 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 61 6c (any->number (al
12ac0 69 73 74 2d 72 65 66 20 27 70 6f 72 74 20 20 20 ist-ref 'port
12ad0 73 72 76 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 srv))).;;; .
12ae0 20 20 20 28 72 65 73 2d 66 75 6c 6c 20 28 69 66 (res-full (if
12af0 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 72 69 (and (equal? ri
12b00 70 61 64 64 72 20 28 61 72 65 61 2d 6d 79 61 64 paddr (area-myad
12b10 64 72 20 61 63 66 67 29 29 0a 3b 3b 3b 20 09 09 dr acfg)).;;; ..
12b20 09 09 20 20 28 65 71 75 61 6c 3f 20 72 70 6f 72 .. (equal? rpor
12b30 74 20 20 20 28 61 72 65 61 2d 70 6f 72 74 20 61 t (area-port a
12b40 63 66 67 29 29 29 0a 3b 3b 3b 20 09 09 09 20 20 cfg))).;;; ...
12b50 20 20 20 28 72 65 71 75 65 73 74 20 61 63 66 67 (request acfg
12b60 20 72 69 70 61 64 64 72 20 72 70 6f 72 74 20 28 ripaddr rport (
12b70 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 area-pktid acfg)
12b80 20 61 63 74 69 6f 6e 20 63 6f 6f 6b 69 65 20 64 action cookie d
12b90 62 6e 61 6d 65 20 70 61 72 61 6d 73 29 0a 3b 3b bname params).;;
12ba0 3b 20 09 09 09 20 20 20 20 20 28 73 61 66 65 2d ; ... (safe-
12bb0 63 61 6c 6c 20 27 72 65 71 75 65 73 74 20 72 69 call 'request ri
12bc0 70 61 64 64 72 20 72 70 6f 72 74 0a 3b 3b 3b 20 paddr rport.;;;
12bd0 09 09 09 09 09 28 61 72 65 61 2d 6d 79 61 64 64 .....(area-myadd
12be0 72 20 61 63 66 67 29 0a 3b 3b 3b 20 09 09 09 09 r acfg).;;; ....
12bf0 09 28 61 72 65 61 2d 70 6f 72 74 20 20 20 61 63 .(area-port ac
12c00 66 67 29 0a 3b 3b 3b 20 09 09 09 09 09 23 3b 28 fg).;;; .....#;(
12c10 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 area-pktid acfg)
12c20 0a 3b 3b 3b 20 09 09 09 09 09 72 73 72 76 69 64 .;;; .....rsrvid
12c30 0a 3b 3b 3b 20 09 09 09 09 09 61 63 74 69 6f 6e .;;; .....action
12c40 20 63 6f 6f 6b 69 65 20 64 62 6e 61 6d 65 20 70 cookie dbname p
12c50 61 72 61 6d 73 29 29 29 29 0a 3b 3b 3b 20 09 20 arams)))).;;; .
12c60 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 65 73 2d ;; (print "res-
12c70 66 75 6c 6c 3a 20 22 20 72 65 73 2d 66 75 6c 6c full: " res-full
12c80 29 0a 3b 3b 3b 20 09 20 20 28 6d 61 74 63 68 20 ).;;; . (match
12c90 72 65 73 2d 66 75 6c 6c 0a 3b 3b 3b 20 09 20 20 res-full.;;; .
12ca0 20 20 28 28 72 65 73 70 6f 6e 73 65 2d 6f 6b 20 ((response-ok
12cb0 72 65 73 70 6f 6e 73 65 2d 6d 73 67 20 72 65 6d response-msg rem
12cc0 20 2e 2e 2e 29 0a 3b 3b 3b 20 09 20 20 20 20 20 ...).;;; .
12cd0 28 6c 65 74 2a 20 28 28 73 65 6e 64 2d 6d 65 73 (let* ((send-mes
12ce0 73 61 67 65 2d 74 69 6d 65 20 28 63 75 72 72 65 sage-time (curre
12cf0 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
12d00 29 0a 3b 3b 3b 20 09 09 20 20 20 20 3b 3b 20 28 ).;;; .. ;; (
12d10 6d 61 74 63 68 20 72 65 73 2d 66 75 6c 6c 0a 3b match res-full.;
12d20 3b 3b 20 09 09 20 20 20 20 3b 3b 20 20 28 28 72 ;; .. ;; ((r
12d30 65 73 70 6f 6e 73 65 2d 6f 6b 20 72 65 73 70 6f esponse-ok respo
12d40 6e 73 65 2d 6d 73 67 29 0a 3b 3b 3b 20 09 09 20 nse-msg).;;; ..
12d50 20 20 20 3b 3b 20 28 72 65 73 70 6f 6e 73 65 2d ;; (response-
12d60 6f 6b 20 20 28 63 61 72 20 72 65 73 2d 66 75 6c ok (car res-ful
12d70 6c 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 3b 3b l)).;;; .. ;;
12d80 20 28 72 65 73 70 6f 6e 73 65 2d 6d 73 67 20 28 (response-msg (
12d90 63 61 64 72 20 72 65 73 2d 66 75 6c 6c 29 0a 3b cadr res-full).;
12da0 3b 3b 20 09 09 20 20 20 20 29 0a 3b 3b 3b 20 09 ;; .. ).;;; .
12db0 20 20 20 20 20 20 20 3b 3b 20 28 72 65 73 20 28 ;; (res (
12dc0 74 61 6b 65 20 72 65 73 2d 66 75 6c 6c 20 33 29 take res-full 3)
12dd0 29 29 20 3b 3b 20 63 74 79 70 65 20 3d 3d 20 61 )) ;; ctype == a
12de0 63 74 69 6f 6e 2c 20 54 4f 44 4f 3a 20 63 6f 6e ction, TODO: con
12df0 76 65 72 67 65 20 6f 6e 20 6f 6e 65 20 74 65 72 verge on one ter
12e00 6d 20 3c 3c 3d 3d 3d 20 77 68 61 74 20 77 61 73 m <<=== what was
12e10 20 74 68 69 73 3f 20 42 55 47 20 0a 3b 3b 3b 20 this? BUG .;;;
12e20 09 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e . ;; (prin
12e30 74 20 22 75 6c 65 78 3a 63 61 6c 6c 3a 20 73 65 t "ulex:call: se
12e40 6e 64 2d 6d 65 73 73 61 67 65 20 74 6f 6f 6b 20 nd-message took
12e50 22 20 28 2d 20 73 65 6e 64 2d 6d 65 73 73 61 67 " (- send-messag
12e60 65 2d 74 69 6d 65 20 70 6f 73 74 2d 67 65 74 2d e-time post-get-
12e70 73 74 61 72 74 2d 74 69 6d 65 29 20 22 20 6d 73 start-time) " ms
12e80 20 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 params=" params
12e90 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 73 ).;;; . (s
12ea0 64 62 67 3e 20 22 63 61 6c 6c 22 20 22 73 65 6e dbg> "call" "sen
12eb0 64 2d 6d 65 73 73 61 67 65 22 20 70 6f 73 74 2d d-message" post-
12ec0 67 65 74 2d 73 74 61 72 74 2d 74 69 6d 65 20 23 get-start-time #
12ed0 66 20 63 61 6c 6c 2d 73 74 61 72 74 2d 74 69 6d f call-start-tim
12ee0 65 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 e).;;; . (
12ef0 63 6f 6e 64 0a 3b 3b 3b 20 09 09 28 28 6e 6f 74 cond.;;; ..((not
12f00 20 72 65 73 70 6f 6e 73 65 2d 6f 6b 29 20 23 66 response-ok) #f
12f10 29 0a 3b 3b 3b 20 09 09 28 28 6d 65 6d 62 65 72 ).;;; ..((member
12f20 20 72 65 73 70 6f 6e 73 65 2d 6d 73 67 20 27 28 response-msg '(
12f30 22 64 62 20 72 65 61 64 20 73 75 62 6d 69 74 74 "db read submitt
12f40 65 64 22 20 22 64 62 20 77 72 69 74 65 20 73 75 ed" "db write su
12f50 62 6d 69 74 74 65 64 22 29 29 0a 3b 3b 3b 20 09 bmitted")).;;; .
12f60 09 20 28 6c 65 74 2a 20 28 28 63 6f 6f 6b 69 65 . (let* ((cookie
12f70 2d 69 64 20 20 20 28 63 61 64 64 64 72 20 72 65 -id (cadddr re
12f80 73 2d 66 75 6c 6c 29 29 0a 3b 3b 3b 20 09 09 09 s-full)).;;; ...
12f90 28 6d 62 6f 78 20 20 20 20 20 20 20 20 28 6d 61 (mbox (ma
12fa0 6b 65 2d 6d 61 69 6c 62 6f 78 29 29 0a 3b 3b 3b ke-mailbox)).;;;
12fb0 20 09 09 09 28 6d 62 6f 78 2d 74 69 6d 65 20 20 ...(mbox-time
12fc0 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
12fd0 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 09 09 econds))).;;; ..
12fe0 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
12ff0 65 74 21 20 28 61 72 65 61 2d 63 6f 6f 6b 69 65 et! (area-cookie
13000 32 6d 62 6f 78 20 61 63 66 67 29 20 63 6f 6f 6b 2mbox acfg) cook
13010 69 65 2d 69 64 20 6d 62 6f 78 29 0a 3b 3b 3b 20 ie-id mbox).;;;
13020 09 09 20 20 20 28 6c 65 74 2a 20 28 28 6d 62 6f .. (let* ((mbo
13030 78 2d 74 69 6d 65 6f 75 74 2d 73 65 63 73 20 20 x-timeout-secs
13040 20 20 32 30 29 0a 3b 3b 3b 20 09 09 09 20 20 28 20).;;; ... (
13050 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d 72 65 73 mbox-timeout-res
13060 75 6c 74 20 27 4d 42 4f 58 5f 54 49 4d 45 4f 55 ult 'MBOX_TIMEOU
13070 54 29 0a 3b 3b 3b 20 09 09 09 20 20 28 72 65 73 T).;;; ... (res
13080 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13090 20 20 28 6d 61 69 6c 62 6f 78 2d 72 65 63 65 69 (mailbox-recei
130a0 76 65 21 20 6d 62 6f 78 20 6d 62 6f 78 2d 74 69 ve! mbox mbox-ti
130b0 6d 65 6f 75 74 2d 73 65 63 73 20 6d 62 6f 78 2d meout-secs mbox-
130c0 74 69 6d 65 6f 75 74 2d 72 65 73 75 6c 74 29 29 timeout-result))
130d0 0a 3b 3b 3b 20 09 09 09 20 20 28 6d 62 6f 78 2d .;;; ... (mbox-
130e0 72 65 63 65 69 76 65 2d 74 69 6d 65 20 20 20 20 receive-time
130f0 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 (current-millise
13100 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 09 09 20 conds))).;;; ..
13110 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
13120 64 65 6c 65 74 65 21 20 28 61 72 65 61 2d 63 6f delete! (area-co
13130 6f 6b 69 65 32 6d 62 6f 78 20 61 63 66 67 29 20 okie2mbox acfg)
13140 63 6f 6f 6b 69 65 2d 69 64 29 0a 3b 3b 3b 20 09 cookie-id).;;; .
13150 09 20 20 20 20 20 28 73 64 62 67 3e 20 22 63 61 . (sdbg> "ca
13160 6c 6c 22 20 22 6d 61 69 6c 62 6f 78 2d 72 65 63 ll" "mailbox-rec
13170 65 69 76 65 22 20 6d 62 6f 78 2d 74 69 6d 65 20 eive" mbox-time
13180 23 66 20 63 61 6c 6c 2d 73 74 61 72 74 2d 74 69 #f call-start-ti
13190 6d 65 20 22 20 66 72 6f 6d 3a 20 22 20 6d 79 69 me " from: " myi
131a0 64 20 22 20 74 6f 20 73 65 72 76 65 72 3a 20 22 d " to server: "
131b0 20 73 72 76 69 64 20 22 20 66 6f 72 20 22 20 64 srvid " for " d
131c0 62 6e 61 6d 65 29 0a 3b 3b 3b 20 09 09 20 20 20 bname).;;; ..
131d0 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 75 6c 65 ;; (print "ule
131e0 78 3a 63 61 6c 6c 20 6d 61 69 6c 62 6f 78 2d 72 x:call mailbox-r
131f0 65 63 65 69 76 65 20 74 6f 6f 6b 20 22 20 28 2d eceive took " (-
13200 20 6d 62 6f 78 2d 72 65 63 65 69 76 65 2d 74 69 mbox-receive-ti
13210 6d 65 20 6d 62 6f 78 2d 74 69 6d 65 29 20 22 6d me mbox-time) "m
13220 73 20 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d s params=" param
13230 73 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 72 65 s).;;; .. re
13240 73 29 29 29 0a 3b 3b 3b 20 09 09 28 65 6c 73 65 s))).;;; ..(else
13250 0a 3b 3b 3b 20 09 09 20 28 70 72 69 6e 74 20 22 .;;; .. (print "
13260 55 6e 68 61 6e 64 6c 65 64 20 72 65 73 70 6f 6e Unhandled respon
13270 73 65 20 5c 22 22 72 65 73 70 6f 6e 73 65 2d 6d se \""response-m
13280 73 67 22 5c 22 22 29 0a 3b 3b 3b 20 09 09 20 23 sg"\"").;;; .. #
13290 66 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 f)).;;; .
132a0 3b 3b 20 64 65 70 65 6e 64 69 6e 67 20 6f 6e 20 ;; depending on
132b0 77 68 61 74 20 61 63 74 69 6f 6e 20 28 69 2e 65 what action (i.e
132c0 2e 20 63 74 79 70 65 29 20 69 73 20 77 65 20 77 . ctype) is we w
132d0 69 6c 6c 20 62 6c 6f 63 6b 20 68 65 72 65 20 77 ill block here w
132e0 61 69 74 69 6e 67 20 66 6f 72 0a 3b 3b 3b 20 09 aiting for.;;; .
132f0 20 20 20 20 20 20 20 3b 3b 20 61 6c 6c 20 74 68 ;; all th
13300 65 20 64 61 74 61 20 28 6d 65 63 68 61 6e 69 73 e data (mechanis
13310 6d 20 74 6f 20 62 65 20 64 65 74 65 72 6d 69 6e m to be determin
13320 65 64 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 ed).;;; .
13330 3b 3b 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 3b ;;.;;; . ;
13340 3b 20 69 66 20 72 65 73 20 69 73 20 61 20 22 77 ; if res is a "w
13350 6f 72 6b 69 6e 67 20 6f 6e 20 69 74 22 20 74 68 orking on it" th
13360 65 6e 20 77 61 69 74 0a 3b 3b 3b 20 09 20 20 20 en wait.;;; .
13370 20 20 20 20 3b 3b 20 20 20 20 77 61 69 74 20 66 ;; wait f
13380 6f 72 20 72 65 73 75 6c 74 0a 3b 3b 3b 20 09 20 or result.;;; .
13390 20 20 20 20 20 20 3b 3b 20 6d 61 69 6c 62 6f 78 ;; mailbox
133a0 20 74 68 72 65 61 64 20 77 61 69 74 20 6f 6e 20 thread wait on
133b0 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 0a 3b 3b .;;; . .;;
133c0 3b 20 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ; . ;; if
133d0 72 65 73 20 69 73 20 61 20 22 63 61 6e 27 74 20 res is a "can't
133e0 68 65 6c 70 20 79 6f 75 22 20 74 68 65 6e 20 74 help you" then t
133f0 72 79 20 61 20 64 69 66 66 65 72 65 6e 74 20 73 ry a different s
13400 65 72 76 65 72 0a 3b 3b 3b 20 09 20 20 20 20 20 erver.;;; .
13410 20 20 3b 3b 20 69 66 20 72 65 73 20 69 73 20 61 ;; if res is a
13420 20 22 61 63 6b 22 20 28 65 2e 67 2e 20 66 6f 72 "ack" (e.g. for
13430 20 6f 6e 65 2d 73 68 6f 74 20 72 65 71 75 65 73 one-shot reques
13440 74 73 29 20 74 68 65 6e 20 72 65 74 75 72 6e 20 ts) then return
13450 72 65 73 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 res.;;; .
13460 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 65 6c 73 )).;;; . (els
13470 65 0a 3b 3b 3b 20 09 20 20 20 20 20 28 69 66 20 e.;;; . (if
13480 28 3c 20 63 6f 75 6e 74 20 31 30 29 0a 3b 3b 3b (< count 10).;;;
13490 20 09 09 20 28 6c 65 74 2a 20 28 28 75 72 6c 20 .. (let* ((url
134a0 28 63 6f 6e 63 20 28 61 6c 69 73 74 2d 72 65 66 (conc (alist-ref
134b0 20 27 69 70 61 64 64 72 20 73 72 76 29 20 22 3a 'ipaddr srv) ":
134c0 22 20 28 61 6c 69 73 74 2d 72 65 66 20 27 70 6f " (alist-ref 'po
134d0 72 74 20 73 72 76 29 29 29 29 0a 3b 3b 3b 20 09 rt srv)))).;;; .
134e0 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 . (thread-slee
134f0 70 21 20 31 29 0a 3b 3b 3b 20 09 09 20 20 20 28 p! 1).;;; .. (
13500 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 42 61 print "ERROR: Ba
13510 64 20 72 65 73 75 6c 74 20 66 72 6f 6d 20 22 20 d result from "
13520 75 72 6c 20 22 2c 20 64 62 6e 61 6d 65 3a 20 22 url ", dbname: "
13530 20 64 62 6e 61 6d 65 20 22 2c 20 61 63 74 69 6f dbname ", actio
13540 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 2c 20 70 n: " action ", p
13550 61 72 61 6d 73 3a 20 22 20 70 61 72 61 6d 73 20 arams: " params
13560 22 2e 20 54 72 79 69 6e 67 20 61 67 61 69 6e 20 ". Trying again
13570 69 6e 20 31 20 73 65 63 6f 6e 64 2e 22 29 0a 3b in 1 second.").;
13580 3b 3b 20 09 09 20 20 20 28 63 61 6c 6c 20 61 63 ;; .. (call ac
13590 66 67 20 64 62 6e 61 6d 65 20 61 63 74 69 6f 6e fg dbname action
135a0 20 70 61 72 61 6d 73 20 28 2b 20 63 6f 75 6e 74 params (+ count
135b0 20 31 29 29 29 0a 3b 3b 3b 20 09 09 20 28 62 65 1))).;;; .. (be
135c0 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 28 65 72 gin.;;; .. (er
135d0 72 6f 72 20 28 63 6f 6e 63 20 22 45 52 52 4f 52 ror (conc "ERROR
135e0 3a 20 22 20 63 6f 75 6e 74 20 22 20 74 72 69 65 : " count " trie
135f0 73 2c 20 73 74 69 6c 6c 20 68 61 76 65 20 69 6d s, still have im
13600 70 72 6f 70 65 72 20 72 65 73 70 6f 6e 73 65 20 proper response
13610 72 65 73 2d 66 75 6c 6c 3d 22 20 72 65 73 2d 66 res-full=" res-f
13620 75 6c 6c 29 29 29 29 29 29 29 0a 3b 3b 3b 20 09 ull))))))).;;; .
13630 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 28 69 (begin.;;; . (i
13640 66 20 28 6e 6f 74 20 72 64 61 74 29 0a 3b 3b 3b f (not rdat).;;;
13650 20 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 . (print "
13660 45 52 52 4f 52 3a 20 61 63 74 69 6f 6e 20 22 20 ERROR: action "
13670 61 63 74 69 6f 6e 20 22 20 6e 6f 74 20 72 65 67 action " not reg
13680 69 73 74 65 72 65 64 2e 22 29 0a 3b 3b 3b 20 09 istered.").;;; .
13690 20 20 20 20 20 20 28 69 66 20 28 3c 20 63 6f 75 (if (< cou
136a0 6e 74 20 31 30 29 0a 3b 3b 3b 20 09 09 20 28 62 nt 10).;;; .. (b
136b0 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 28 74 egin.;;; .. (t
136c0 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
136d0 3b 3b 3b 20 09 09 20 20 20 28 61 72 65 61 2d 68 ;;; .. (area-h
136e0 6f 73 74 73 2d 73 65 74 21 20 61 63 66 67 20 28 osts-set! acfg (
136f0 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
13700 29 20 3b 3b 20 63 6c 65 61 72 20 6f 75 74 20 61 ) ;; clear out a
13710 6c 6c 20 6b 6e 6f 77 6e 20 68 6f 73 74 73 0a 3b ll known hosts.;
13720 3b 3b 20 09 09 20 20 20 28 70 72 69 6e 74 20 22 ;; .. (print "
13730 45 52 52 4f 52 3a 20 6e 6f 20 73 65 72 76 65 72 ERROR: no server
13740 20 66 6f 75 6e 64 2c 20 73 72 76 3d 22 20 73 72 found, srv=" sr
13750 76 20 22 2c 20 74 72 79 69 6e 67 20 61 67 61 69 v ", trying agai
13760 6e 20 69 6e 20 31 20 73 65 63 6f 6e 64 73 22 29 n in 1 seconds")
13770 0a 3b 3b 3b 20 09 09 20 20 20 28 63 61 6c 6c 20 .;;; .. (call
13780 61 63 66 67 20 64 62 6e 61 6d 65 20 61 63 74 69 acfg dbname acti
13790 6f 6e 20 70 61 72 61 6d 73 20 28 2b 20 63 6f 75 on params (+ cou
137a0 6e 74 20 31 29 29 29 0a 3b 3b 3b 20 09 09 20 28 nt 1))).;;; .. (
137b0 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 28 begin.;;; .. (
137c0 65 72 72 6f 72 20 28 63 6f 6e 63 20 22 45 52 52 error (conc "ERR
137d0 4f 52 3a 20 6e 6f 20 73 65 72 76 65 72 20 66 6f OR: no server fo
137e0 75 6e 64 20 61 66 74 65 72 20 31 30 20 74 72 69 und after 10 tri
137f0 65 73 2c 20 73 72 76 3d 22 20 73 72 76 20 22 2c es, srv=" srv ",
13800 20 67 69 76 69 6e 67 20 75 70 2e 22 29 29 0a 3b giving up.")).;
13810 3b 3b 20 09 09 20 20 20 23 3b 28 65 72 72 6f 72 ;; .. #;(error
13820 20 22 4e 6f 20 73 65 72 76 65 72 20 61 76 61 69 "No server avai
13830 6c 61 62 6c 65 22 29 29 29 29 29 29 29 29 0a 3b lable")))))))).;
13840 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d ;; .;;; .;;; ;;=
13850 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13860 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13870 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13880 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13890 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 55 20 54 =====.;;; ;; U T
138a0 20 49 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a I L I T I E S .
138b0 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;; ;;==========
138c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
138d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
138e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
138f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b ============.;;;
13900 20 0a 3b 3b 3b 20 3b 3b 20 67 65 74 20 61 20 73 .;;; ;; get a s
13910 69 67 6e 61 74 75 72 65 20 66 6f 72 20 69 64 65 ignature for ide
13920 6e 74 69 66 69 6e 67 20 74 68 69 73 20 70 72 6f ntifing this pro
13930 63 65 73 73 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 cess.;;; ;;.;;;
13940 28 64 65 66 69 6e 65 20 28 67 65 74 2d 70 72 6f (define (get-pro
13950 63 65 73 73 2d 73 69 67 6e 61 74 75 72 65 29 0a cess-signature).
13960 3b 3b 3b 20 20 20 28 63 6f 6e 73 20 28 67 65 74 ;;; (cons (get
13970 2d 68 6f 73 74 2d 6e 61 6d 65 29 28 63 75 72 72 -host-name)(curr
13980 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 ent-process-id))
13990 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d ).;;; .;;; ;;===
139a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
139b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
139c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
139d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
139e0 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 53 20 59 20 53 ===.;;; ;; S Y S
139f0 20 54 20 45 20 4d 20 20 20 53 20 54 20 55 20 46 T E M S T U F
13a00 20 46 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d F.;;; ;;=======
13a10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
13a50 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 67 65 74 20 ;;; .;;; ;; get
13a60 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c normalized cpu l
13a70 6f 61 64 20 62 79 20 72 65 61 64 69 6e 67 20 66 oad by reading f
13a80 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 rom /proc/loadav
13a90 67 20 61 6e 64 0a 3b 3b 3b 20 3b 3b 20 2f 70 72 g and.;;; ;; /pr
13aa0 6f 63 2f 63 70 75 69 6e 66 6f 20 72 65 74 75 72 oc/cpuinfo retur
13ab0 6e 20 61 6c 6c 20 74 68 72 65 65 20 76 61 6c 75 n all three valu
13ac0 65 73 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 65 es and the numbe
13ad0 72 20 6f 66 20 72 65 61 6c 20 63 70 75 73 0a 3b r of real cpus.;
13ae0 3b 3b 20 3b 3b 20 61 6e 64 20 74 68 65 20 6e 75 ;; ;; and the nu
13af0 6d 62 65 72 20 6f 66 20 74 68 72 65 61 64 73 20 mber of threads
13b00 72 65 74 75 72 6e 73 20 61 6c 69 73 74 20 27 28 returns alist '(
13b10 28 61 64 6a 2d 63 70 75 2d 6c 6f 61 64 0a 3b 3b (adj-cpu-load.;;
13b20 3b 20 3b 3b 20 2e 20 6e 6f 72 6d 61 6c 69 7a 65 ; ;; . normalize
13b30 64 2d 70 72 6f 63 2d 6c 6f 61 64 29 20 2e 2e 2e d-proc-load) ...
13b40 20 65 74 63 2e 20 20 6b 65 79 73 3a 20 61 64 6a etc. keys: adj
13b50 2d 70 72 6f 63 2d 6c 6f 61 64 2c 0a 3b 3b 3b 20 -proc-load,.;;;
13b60 3b 3b 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 ;; adj-core-load
13b70 2c 20 31 6d 2d 6c 6f 61 64 2c 20 35 6d 2d 6c 6f , 1m-load, 5m-lo
13b80 61 64 2c 20 31 35 6d 2d 6c 6f 61 64 0a 3b 3b 3b ad, 15m-load.;;;
13b90 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 ;;.;;; (define
13ba0 28 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d (get-normalized-
13bb0 63 70 75 2d 6c 6f 61 64 29 0a 3b 3b 3b 20 20 20 cpu-load).;;;
13bc0 28 6c 65 74 20 28 28 72 65 73 20 28 67 65 74 2d (let ((res (get-
13bd0 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c normalized-cpu-l
13be0 6f 61 64 2d 72 61 77 29 29 0a 3b 3b 3b 20 09 28 oad-raw)).;;; .(
13bf0 64 65 66 61 75 6c 74 20 60 28 28 61 64 6a 2d 70 default `((adj-p
13c00 72 6f 63 2d 6c 6f 61 64 20 2e 20 32 29 20 3b 3b roc-load . 2) ;;
13c10 20 74 68 65 72 65 20 69 73 20 6e 6f 20 72 69 67 there is no rig
13c20 68 74 20 61 6e 73 77 65 72 0a 3b 3b 3b 20 09 09 ht answer.;;; ..
13c30 20 20 20 28 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 (adj-core-loa
13c40 64 20 2e 20 32 29 0a 3b 3b 3b 20 09 09 20 20 20 d . 2).;;; ..
13c50 28 31 6d 2d 6c 6f 61 64 20 20 20 20 20 20 20 2e (1m-load .
13c60 20 32 29 0a 3b 3b 3b 20 09 09 20 20 20 28 35 6d 2).;;; .. (5m
13c70 2d 6c 6f 61 64 20 20 20 20 20 20 20 2e 20 30 29 -load . 0)
13c80 20 3b 3b 20 63 61 75 73 65 73 20 61 20 6c 61 72 ;; causes a lar
13c90 67 65 20 64 65 6c 74 61 20 2d 20 74 68 75 73 20 ge delta - thus
13ca0 63 61 75 73 69 6e 67 20 64 65 66 61 75 6c 74 20 causing default
13cb0 6f 66 20 74 68 72 6f 74 74 6c 69 6e 67 20 69 66 of throttling if
13cc0 20 73 74 75 66 66 20 67 6f 65 73 20 77 72 6f 6e stuff goes wron
13cd0 67 0a 3b 3b 3b 20 09 09 20 20 20 28 31 35 6d 2d g.;;; .. (15m-
13ce0 6c 6f 61 64 20 20 20 20 20 20 2e 20 30 29 0a 3b load . 0).;
13cf0 3b 3b 20 09 09 20 20 20 28 70 72 6f 63 20 20 20 ;; .. (proc
13d00 20 20 20 20 20 20 20 2e 20 31 29 0a 3b 3b 3b 20 . 1).;;;
13d10 09 09 20 20 20 28 63 6f 72 65 20 20 20 20 20 20 .. (core
13d20 20 20 20 20 2e 20 31 29 0a 3b 3b 3b 20 09 09 20 . 1).;;; ..
13d30 20 20 28 70 68 79 73 20 20 20 20 20 20 20 20 20 (phys
13d40 20 2e 20 31 29 0a 3b 3b 3b 20 09 09 20 20 20 28 . 1).;;; .. (
13d50 65 72 72 6f 72 20 20 20 20 20 20 20 20 20 2e 20 error .
13d60 23 74 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 #t)))).;;; (
13d70 63 6f 6e 64 0a 3b 3b 3b 20 20 20 20 20 20 28 28 cond.;;; ((
13d80 61 6e 64 20 28 6c 69 73 74 3f 20 72 65 73 29 0a and (list? res).
13d90 3b 3b 3b 20 09 20 20 20 28 3e 20 28 6c 65 6e 67 ;;; . (> (leng
13da0 74 68 20 72 65 73 29 20 32 29 29 0a 3b 3b 3b 20 th res) 2)).;;;
13db0 20 20 20 20 20 20 72 65 73 29 0a 3b 3b 3b 20 20 res).;;;
13dc0 20 20 20 20 28 28 65 71 3f 20 72 65 73 20 23 66 ((eq? res #f
13dd0 29 20 20 20 64 65 66 61 75 6c 74 29 20 3b 3b 20 ) default) ;;
13de0 61 64 64 20 6d 65 73 73 61 67 65 73 3f 0a 3b 3b add messages?.;;
13df0 3b 20 20 20 20 20 20 28 28 65 71 3f 20 72 65 73 ; ((eq? res
13e00 20 23 66 29 20 64 65 66 61 75 6c 74 29 20 20 20 #f) default)
13e10 3b 3b 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 ;; this would be
13e20 20 74 68 65 20 23 65 6f 66 0a 3b 3b 3b 20 20 20 the #eof.;;;
13e30 20 20 20 28 65 6c 73 65 20 64 65 66 61 75 6c 74 (else default
13e40 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 )))).;;; .;;; (d
13e50 65 66 69 6e 65 20 28 67 65 74 2d 6e 6f 72 6d 61 efine (get-norma
13e60 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 2d 72 lized-cpu-load-r
13e70 61 77 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 aw).;;; (let*
13e80 28 28 61 63 74 75 61 6c 2d 68 6f 73 74 20 20 20 ((actual-host
13e90 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 6f 73 (get-hos
13ea0 74 2d 6e 61 6d 65 29 29 29 20 3b 3b 20 23 66 20 t-name))) ;; #f
13eb0 69 73 20 6c 6f 63 61 6c 68 6f 73 74 0a 3b 3b 3b is localhost.;;;
13ec0 20 20 20 20 20 28 6c 65 74 20 28 28 64 61 74 61 (let ((data
13ed0 20 20 28 61 70 70 65 6e 64 20 0a 3b 3b 3b 20 09 (append .;;; .
13ee0 09 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 . (with-input-f
13ef0 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f rom-file "/proc/
13f00 6c 6f 61 64 61 76 67 22 20 72 65 61 64 2d 6c 69 loadavg" read-li
13f10 6e 65 73 29 0a 3b 3b 3b 20 09 09 20 20 28 77 69 nes).;;; .. (wi
13f20 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 th-input-from-fi
13f30 6c 65 20 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 le "/proc/cpuinf
13f40 6f 22 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a 3b o" read-lines).;
13f50 3b 3b 20 09 09 20 20 28 6c 69 73 74 20 22 65 6e ;; .. (list "en
13f60 64 22 29 29 29 0a 3b 3b 3b 20 09 20 20 28 6c 6f d"))).;;; . (lo
13f70 61 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 ad-rx (regexp "
13f80 5e 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b ^([\\d\\.]+)\\s+
13f90 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 ([\\d\\.]+)\\s+(
13fa0 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 2e 2a [\\d\\.]+)\\s+.*
13fb0 24 22 29 29 0a 3b 3b 3b 20 09 20 20 28 70 72 6f $")).;;; . (pro
13fc0 63 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e c-rx (regexp "^
13fd0 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c processor\\s+:\\
13fe0 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 s+(\\d+)\\s*$"))
13ff0 0a 3b 3b 3b 20 09 20 20 28 63 6f 72 65 2d 72 78 .;;; . (core-rx
14000 20 20 28 72 65 67 65 78 70 20 22 5e 63 6f 72 65 (regexp "^core
14010 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 id\\s+:\\s+(\\d
14020 2b 29 5c 5c 73 2a 24 22 29 29 0a 3b 3b 3b 20 09 +)\\s*$")).;;; .
14030 20 20 28 70 68 79 73 2d 72 78 20 20 28 72 65 67 (phys-rx (reg
14040 65 78 70 20 22 5e 70 68 79 73 69 63 61 6c 20 69 exp "^physical i
14050 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 d\\s+:\\s+(\\d+)
14060 5c 5c 73 2a 24 22 29 29 0a 3b 3b 3b 20 09 20 20 \\s*$")).;;; .
14070 28 6d 61 78 2d 6e 75 6d 20 20 28 6c 61 6d 62 64 (max-num (lambd
14080 61 20 28 70 20 6e 29 28 6d 61 78 20 28 73 74 72 a (p n)(max (str
14090 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 29 20 6e ing->number p) n
140a0 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 3b )))).;;; ;
140b0 3b 20 28 70 72 69 6e 74 20 22 64 61 74 61 3d 22 ; (print "data="
140c0 20 64 61 74 61 29 0a 3b 3b 3b 20 20 20 20 20 20 data).;;;
140d0 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 61 (if (null? data
140e0 29 20 3b 3b 20 73 6f 6d 65 74 68 69 6e 67 20 77 ) ;; something w
140f0 65 6e 74 20 77 72 6f 6e 67 0a 3b 3b 3b 20 09 20 ent wrong.;;; .
14100 20 23 66 0a 3b 3b 3b 20 09 20 20 28 6c 65 74 20 #f.;;; . (let
14110 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 20 loop ((hed
14120 28 63 61 72 20 64 61 74 61 29 29 0a 3b 3b 3b 20 (car data)).;;;
14130 09 09 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 .. (tal
14140 20 28 63 64 72 20 64 61 74 61 29 29 0a 3b 3b 3b (cdr data)).;;;
14150 20 09 09 20 20 20 20 20 28 6c 6f 61 64 73 20 20 .. (loads
14160 20 20 23 66 29 0a 3b 3b 3b 20 09 09 20 20 20 20 #f).;;; ..
14170 20 28 70 72 6f 63 2d 6e 75 6d 20 30 29 20 20 3b (proc-num 0) ;
14180 3b 20 70 72 6f 63 65 73 73 6f 72 20 69 6e 63 6c ; processor incl
14190 75 64 65 73 20 74 68 72 65 61 64 73 0a 3b 3b 3b udes threads.;;;
141a0 20 09 09 20 20 20 20 20 28 70 68 79 73 2d 6e 75 .. (phys-nu
141b0 6d 20 30 29 20 20 3b 3b 20 70 68 79 73 69 63 61 m 0) ;; physica
141c0 6c 20 63 68 69 70 20 6f 6e 20 6d 6f 74 68 65 72 l chip on mother
141d0 62 6f 61 72 64 0a 3b 3b 3b 20 09 09 20 20 20 20 board.;;; ..
141e0 20 28 63 6f 72 65 2d 6e 75 6d 20 30 29 29 20 3b (core-num 0)) ;
141f0 3b 20 63 6f 72 65 0a 3b 3b 3b 20 09 20 20 20 20 ; core.;;; .
14200 3b 3b 20 28 70 72 69 6e 74 20 68 65 64 20 22 2c ;; (print hed ",
14210 20 22 20 6c 6f 61 64 73 20 22 2c 20 22 20 70 72 " loads ", " pr
14220 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 70 68 79 73 oc-num ", " phys
14230 2d 6e 75 6d 20 22 2c 20 22 20 63 6f 72 65 2d 6e -num ", " core-n
14240 75 6d 29 0a 3b 3b 3b 20 09 20 20 20 20 28 69 66 um).;;; . (if
14250 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 (null? tal) ;;
14260 68 61 76 65 20 61 6c 6c 20 6f 75 72 20 64 61 74 have all our dat
14270 61 2c 20 63 61 6c 63 75 6c 61 74 65 20 6e 6f 72 a, calculate nor
14280 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 20 61 6e 64 malized load and
14290 20 72 65 74 75 72 6e 20 72 65 73 75 6c 74 0a 3b return result.;
142a0 3b 3b 20 09 09 28 6c 65 74 2a 20 28 28 61 63 74 ;; ..(let* ((act
142b0 2d 70 72 6f 63 20 28 2b 20 70 72 6f 63 2d 6e 75 -proc (+ proc-nu
142c0 6d 20 31 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 m 1)).;;; ..
142d0 20 20 20 28 61 63 74 2d 70 68 79 73 20 28 2b 20 (act-phys (+
142e0 70 68 79 73 2d 6e 75 6d 20 31 29 29 0a 3b 3b 3b phys-num 1)).;;;
142f0 20 09 09 20 20 20 20 20 20 20 28 61 63 74 2d 63 .. (act-c
14300 6f 72 65 20 28 2b 20 63 6f 72 65 2d 6e 75 6d 20 ore (+ core-num
14310 31 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 1)).;;; ..
14320 20 28 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 (adj-proc-load
14330 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 20 61 (/ (car loads) a
14340 63 74 2d 70 72 6f 63 29 29 0a 3b 3b 3b 20 09 09 ct-proc)).;;; ..
14350 20 20 20 20 20 20 20 28 61 64 6a 2d 63 6f 72 65 (adj-core
14360 2d 6c 6f 61 64 20 28 2f 20 28 63 61 72 20 6c 6f -load (/ (car lo
14370 61 64 73 29 20 61 63 74 2d 63 6f 72 65 29 29 0a ads) act-core)).
14380 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 28 72 65 ;;; .. (re
14390 73 75 6c 74 0a 3b 3b 3b 20 09 09 09 28 61 70 70 sult.;;; ...(app
143a0 65 6e 64 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 end (list (cons
143b0 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 61 'adj-proc-load a
143c0 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 29 0a 3b 3b dj-proc-load).;;
143d0 3b 20 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e ; .... (con
143e0 73 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 s 'adj-core-load
143f0 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 29 29 adj-core-load))
14400 0a 3b 3b 3b 20 09 09 09 09 28 6c 69 73 74 20 28 .;;; ....(list (
14410 63 6f 6e 73 20 27 31 6d 2d 6c 6f 61 64 20 28 63 cons '1m-load (c
14420 61 72 20 6c 6f 61 64 73 29 29 0a 3b 3b 3b 20 09 ar loads)).;;; .
14430 09 09 09 20 20 20 20 20 20 28 63 6f 6e 73 20 27 ... (cons '
14440 35 6d 2d 6c 6f 61 64 20 28 63 61 64 72 20 6c 6f 5m-load (cadr lo
14450 61 64 73 29 29 0a 3b 3b 3b 20 09 09 09 09 20 20 ads)).;;; ....
14460 20 20 20 20 28 63 6f 6e 73 20 27 31 35 6d 2d 6c (cons '15m-l
14470 6f 61 64 20 28 63 61 64 64 72 20 6c 6f 61 64 73 oad (caddr loads
14480 29 29 29 0a 3b 3b 3b 20 09 09 09 09 28 6c 69 73 ))).;;; ....(lis
14490 74 20 28 63 6f 6e 73 20 27 70 72 6f 63 20 61 63 t (cons 'proc ac
144a0 74 2d 70 72 6f 63 29 0a 3b 3b 3b 20 09 09 09 09 t-proc).;;; ....
144b0 20 20 20 20 20 20 28 63 6f 6e 73 20 27 63 6f 72 (cons 'cor
144c0 65 20 61 63 74 2d 63 6f 72 65 29 0a 3b 3b 3b 20 e act-core).;;;
144d0 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e 73 20 .... (cons
144e0 27 70 68 79 73 20 61 63 74 2d 70 68 79 73 29 29 'phys act-phys))
144f0 29 29 29 0a 3b 3b 3b 20 09 09 20 20 72 65 73 75 ))).;;; .. resu
14500 6c 74 29 0a 3b 3b 3b 20 09 09 28 72 65 67 65 78 lt).;;; ..(regex
14510 2d 63 61 73 65 0a 3b 3b 3b 20 09 09 20 20 20 20 -case.;;; ..
14520 68 65 64 0a 3b 3b 3b 20 09 09 20 20 28 6c 6f 61 hed.;;; .. (loa
14530 64 2d 72 78 20 20 28 20 78 20 6c 31 20 6c 35 20 d-rx ( x l1 l5
14540 6c 31 35 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 l15 ) (loop (car
14550 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 6d tal)(cdr tal)(m
14560 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 ap string->numbe
14570 72 20 28 6c 69 73 74 20 6c 31 20 6c 35 20 6c 31 r (list l1 l5 l1
14580 35 29 29 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 5)) proc-num phy
14590 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 s-num core-num))
145a0 0a 3b 3b 3b 20 09 09 20 20 28 70 72 6f 63 2d 72 .;;; .. (proc-r
145b0 78 20 20 28 20 78 20 70 20 20 20 20 20 20 20 20 x ( x p
145c0 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 ) (loop (car ta
145d0 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 l)(cdr tal) load
145e0 73 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 78 s (max
145f0 2d 6e 75 6d 20 70 20 70 72 6f 63 2d 6e 75 6d 29 -num p proc-num)
14600 20 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e phys-num core-n
14610 75 6d 29 29 0a 3b 3b 3b 20 09 09 20 20 28 70 68 um)).;;; .. (ph
14620 79 73 2d 72 78 20 20 28 20 78 20 70 20 20 20 20 ys-rx ( x p
14630 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 ) (loop (ca
14640 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
14650 6c 6f 61 64 73 20 20 20 20 20 20 20 20 20 20 20 loads
14660 70 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 proc-num (max-nu
14670 6d 20 70 20 70 68 79 73 2d 6e 75 6d 29 20 63 6f m p phys-num) co
14680 72 65 2d 6e 75 6d 29 29 0a 3b 3b 3b 20 09 09 20 re-num)).;;; ..
14690 20 28 63 6f 72 65 2d 72 78 20 20 28 20 78 20 63 (core-rx ( x c
146a0 20 20 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 ) (loop
146b0 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
146c0 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 al) loads
146d0 20 20 20 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 proc-num phy
146e0 73 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 6d 20 63 s-num (max-num c
146f0 20 63 6f 72 65 2d 6e 75 6d 29 29 29 0a 3b 3b 3b core-num))).;;;
14700 20 09 09 20 20 28 65 6c 73 65 20 0a 3b 3b 3b 20 .. (else .;;;
14710 09 09 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 .. (begin.;;;
14720 09 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 .. ;; (print
14730 20 22 4e 4f 20 4d 41 54 43 48 3a 20 22 20 68 65 "NO MATCH: " he
14740 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 6c d).;;; .. (l
14750 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
14760 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 70 72 6f r tal) loads pro
14770 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 63 c-num phys-num c
14780 6f 72 65 2d 6e 75 6d 29 29 29 29 29 29 29 29 29 ore-num)))))))))
14790 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 ).;;; .;;; (defi
147a0 6e 65 20 28 67 65 74 2d 68 6f 73 74 2d 73 74 61 ne (get-host-sta
147b0 74 73 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 28 ts acfg).;;; (
147c0 6c 65 74 20 28 28 73 74 61 74 73 2d 68 61 73 68 let ((stats-hash
147d0 20 28 61 72 65 61 2d 73 74 61 74 73 20 61 63 66 (area-stats acf
147e0 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 g))).;;; ;;
147f0 75 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 use this opportu
14800 6e 69 74 79 20 74 6f 20 72 65 6d 6f 76 65 20 72 nity to remove r
14810 65 66 65 72 65 6e 63 65 73 20 74 6f 20 64 62 66 eferences to dbf
14820 69 6c 65 73 20 77 68 69 63 68 20 68 61 76 65 20 iles which have
14830 6e 6f 74 20 62 65 65 6e 20 61 63 63 65 73 73 65 not been accesse
14840 64 20 69 6e 20 61 20 77 68 69 6c 65 0a 3b 3b 3b d in a while.;;;
14850 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b (for-each.;
14860 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ;; (lambda
14870 28 64 62 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 20 (dbname).;;;
14880 20 20 20 20 28 6c 65 74 2a 20 28 28 73 74 61 74 (let* ((stat
14890 73 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 s (hash-ta
148a0 62 6c 65 2d 72 65 66 20 73 74 61 74 73 2d 68 61 ble-ref stats-ha
148b0 73 68 20 64 62 6e 61 6d 65 29 29 0a 3b 3b 3b 20 sh dbname)).;;;
148c0 09 20 20 20 20 20 20 28 6c 61 73 74 2d 61 63 63 . (last-acc
148d0 65 73 73 20 28 73 74 61 74 2d 77 68 65 6e 20 73 ess (stat-when s
148e0 74 61 74 73 29 29 29 0a 3b 3b 3b 20 09 20 28 69 tats))).;;; . (i
148f0 66 20 28 61 6e 64 20 28 3e 20 6c 61 73 74 2d 61 f (and (> last-a
14900 63 63 65 73 73 20 30 29 20 20 20 20 20 20 20 20 ccess 0)
14910 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14920 20 20 20 20 20 3b 3b 20 69 66 20 7a 65 72 6f 20 ;; if zero
14930 74 68 65 6e 20 74 68 65 72 65 20 68 61 73 20 62 then there has b
14940 65 65 6e 20 6e 6f 20 61 63 63 65 73 73 0a 3b 3b een no access.;;
14950 3b 20 09 09 20 20 28 3e 20 28 2d 20 28 63 75 72 ; .. (> (- (cur
14960 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 rent-seconds) la
14970 73 74 2d 61 63 63 65 73 73 29 20 31 30 29 29 20 st-access) 10))
14980 20 20 20 20 3b 3b 20 6e 6f 74 20 75 73 65 64 20 ;; not used
14990 69 6e 20 74 65 6e 20 73 65 63 6f 6e 64 73 0a 3b in ten seconds.;
149a0 3b 3b 20 09 20 20 20 20 20 28 62 65 67 69 6e 0a ;; . (begin.
149b0 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 70 72 69 ;;; . (pri
149c0 6e 74 20 22 52 65 6d 6f 76 69 6e 67 20 22 20 64 nt "Removing " d
149d0 62 6e 61 6d 65 20 22 20 66 72 6f 6d 20 73 74 61 bname " from sta
149e0 74 73 20 6c 69 73 74 22 29 0a 3b 3b 3b 20 09 20 ts list").;;; .
149f0 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
14a00 65 2d 64 65 6c 65 74 65 21 20 73 74 61 74 73 2d e-delete! stats-
14a10 68 61 73 68 20 64 62 6e 61 6d 65 29 20 3b 3b 20 hash dbname) ;;
14a20 72 65 6d 6f 76 65 20 66 72 6f 6d 20 73 74 61 74 remove from stat
14a30 73 20 68 61 73 68 0a 3b 3b 3b 20 09 20 20 20 20 s hash.;;; .
14a40 20 20 20 28 73 74 61 74 2d 64 62 73 2d 73 65 74 (stat-dbs-set
14a50 21 20 73 74 61 74 73 20 28 68 61 73 68 2d 74 61 ! stats (hash-ta
14a60 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 73 29 29 ble-keys stats))
14a70 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 28 68 )))).;;; (h
14a80 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 ash-table-keys s
14a90 74 61 74 73 2d 68 61 73 68 29 29 0a 3b 3b 3b 20 tats-hash)).;;;
14aa0 20 20 20 20 0a 3b 3b 3b 20 20 20 20 20 60 28 2c .;;; `(,
14ab0 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
14ac0 73 74 20 28 61 72 65 61 2d 64 62 73 20 61 63 66 st (area-dbs acf
14ad0 67 29 29 20 3b 3b 20 64 62 6e 61 6d 65 20 3d 3e g)) ;; dbname =>
14ae0 20 72 61 6e 64 6e 75 6d 0a 3b 3b 3b 20 20 20 20 randnum.;;;
14af0 20 20 20 2c 28 6d 61 70 20 28 6c 61 6d 62 64 61 ,(map (lambda
14b00 20 28 64 62 6e 61 6d 65 29 20 20 3b 3b 20 64 62 (dbname) ;; db
14b10 6e 61 6d 65 20 69 73 20 74 68 65 20 64 62 20 6e name is the db n
14b20 61 6d 65 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 ame.;;; . (
14b30 63 6f 6e 73 20 64 62 6e 61 6d 65 20 28 73 74 61 cons dbname (sta
14b40 74 2d 77 68 65 6e 20 28 68 61 73 68 2d 74 61 62 t-when (hash-tab
14b50 6c 65 2d 72 65 66 20 73 74 61 74 73 2d 68 61 73 le-ref stats-has
14b60 68 20 64 62 6e 61 6d 65 29 29 29 29 0a 3b 3b 3b h dbname)))).;;;
14b70 20 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c . (hash-tabl
14b80 65 2d 6b 65 79 73 20 73 74 61 74 73 2d 68 61 73 e-keys stats-has
14b90 68 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 63 h)).;;; (c
14ba0 70 75 6c 6f 61 64 20 2e 20 2c 28 67 65 74 2d 6e puload . ,(get-n
14bb0 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f ormalized-cpu-lo
14bc0 61 64 29 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 ad))))).;;;
14bd0 23 3b 28 73 74 61 74 73 20 20 20 2e 20 2c 28 6d #;(stats . ,(m
14be0 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 20 3b ap (lambda (k) ;
14bf0 3b 20 63 72 65 61 74 65 20 61 6e 20 61 6c 69 73 ; create an alis
14c00 74 20 66 72 6f 6d 20 74 68 65 20 73 74 61 74 73 t from the stats
14c10 20 64 61 74 61 0a 3b 3b 3b 20 09 09 20 20 20 20 data.;;; ..
14c20 20 20 20 28 63 6f 6e 73 20 6b 20 28 73 74 61 74 (cons k (stat
14c30 2d 3e 61 6c 69 73 74 20 28 68 61 73 68 2d 74 61 ->alist (hash-ta
14c40 62 6c 65 2d 72 65 66 20 28 61 72 65 61 2d 73 74 ble-ref (area-st
14c50 61 74 73 20 61 63 66 67 29 20 6b 29 29 29 29 0a ats acfg) k)))).
14c60 3b 3b 3b 20 09 09 20 20 20 20 20 28 68 61 73 68 ;;; .. (hash
14c70 2d 74 61 62 6c 65 2d 6b 65 79 73 20 28 61 72 65 -table-keys (are
14c80 61 2d 73 74 61 74 73 20 61 63 66 67 29 29 29 29 a-stats acfg))))
14c90 0a 3b 3b 3b 20 0a 3b 3b 3b 20 23 3b 28 74 72 61 .;;; .;;; #;(tra
14ca0 63 65 0a 3b 3b 3b 20 20 3b 3b 20 61 73 73 76 0a ce.;;; ;; assv.
14cb0 3b 3b 3b 20 20 3b 3b 20 63 64 72 0a 3b 3b 3b 20 ;;; ;; cdr.;;;
14cc0 20 3b 3b 20 63 61 61 72 0a 3b 3b 3b 20 20 3b 3b ;; caar.;;; ;;
14cd0 20 3b 3b 20 63 64 72 0a 3b 3b 3b 20 20 3b 3b 20 ;; cdr.;;; ;;
14ce0 63 61 6c 6c 0a 3b 3b 3b 20 20 3b 3b 20 66 69 6e call.;;; ;; fin
14cf0 61 6c 69 7a 65 2d 61 6c 6c 2d 64 62 2d 68 61 6e alize-all-db-han
14d00 64 6c 65 73 0a 3b 3b 3b 20 20 3b 3b 20 67 65 74 dles.;;; ;; get
14d10 2d 61 6c 6c 2d 73 65 72 76 65 72 2d 70 6b 74 73 -all-server-pkts
14d20 0a 3b 3b 3b 20 20 3b 3b 20 67 65 74 2d 6e 6f 72 .;;; ;; get-nor
14d30 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
14d40 0a 3b 3b 3b 20 20 3b 3b 20 67 65 74 2d 6e 6f 72 .;;; ;; get-nor
14d50 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
14d60 2d 72 61 77 0a 3b 3b 3b 20 20 3b 3b 20 6c 61 75 -raw.;;; ;; lau
14d70 6e 63 68 0a 3b 3b 3b 20 20 3b 3b 20 6e 6d 73 67 nch.;;; ;; nmsg
14d80 2d 73 65 6e 64 0a 3b 3b 3b 20 20 3b 3b 20 70 72 -send.;;; ;; pr
14d90 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 69 65 73 ocess-db-queries
14da0 0a 3b 3b 3b 20 20 3b 3b 20 72 65 63 65 69 76 65 .;;; ;; receive
14db0 2d 6d 65 73 73 61 67 65 0a 3b 3b 3b 20 20 3b 3b -message.;;; ;;
14dc0 20 73 74 64 2d 70 65 65 72 2d 68 61 6e 64 6c 65 std-peer-handle
14dd0 72 0a 3b 3b 3b 20 20 3b 3b 20 75 70 64 61 74 65 r.;;; ;; update
14de0 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 0a 3b -known-servers.;
14df0 3b 3b 20 20 3b 3b 20 77 6f 72 6b 2d 71 75 65 75 ;; ;; work-queu
14e00 65 2d 70 72 6f 63 65 73 73 6f 72 0a 3b 3b 3b 20 e-processor.;;;
14e10 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d ).;;; .;;; ;;==
14e20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e60 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 6e 65 74 75 ====.;;; ;; netu
14e70 74 69 6c 0a 3b 3b 3b 20 3b 3b 20 20 20 6d 6f 76 til.;;; ;; mov
14e80 65 20 74 68 69 73 20 62 61 63 6b 20 74 6f 20 75 e this back to u
14e90 6c 65 78 2d 6e 65 74 75 74 69 6c 2e 73 63 6d 20 lex-netutil.scm
14ea0 73 6f 6d 65 64 61 79 3f 0a 3b 3b 3b 20 3b 3b 3d someday?.;;; ;;=
14eb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ec0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ed0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ee0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ef0 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b =====.;;; .;;; ;
14f00 3b 20 23 69 6e 63 6c 75 64 65 20 3c 73 74 64 69 ; #include <stdi
14f10 6f 2e 68 3e 0a 3b 3b 3b 20 3b 3b 20 23 69 6e 63 o.h>.;;; ;; #inc
14f20 6c 75 64 65 20 3c 6e 65 74 69 6e 65 74 2f 69 6e lude <netinet/in
14f30 2e 68 3e 0a 3b 3b 3b 20 3b 3b 20 23 69 6e 63 6c .h>.;;; ;; #incl
14f40 75 64 65 20 3c 73 74 72 69 6e 67 2e 68 3e 0a 3b ude <string.h>.;
14f50 3b 3b 20 3b 3b 20 23 69 6e 63 6c 75 64 65 20 3c ;; ;; #include <
14f60 61 72 70 61 2f 69 6e 65 74 2e 68 3e 0a 3b 3b 3b arpa/inet.h>.;;;
14f70 20 0a 3b 3b 3b 20 28 66 6f 72 65 69 67 6e 2d 64 .;;; (foreign-d
14f80 65 63 6c 61 72 65 20 22 23 69 6e 63 6c 75 64 65 eclare "#include
14f90 20 5c 22 73 79 73 2f 74 79 70 65 73 2e 68 5c 22 \"sys/types.h\"
14fa0 22 29 0a 3b 3b 3b 20 28 66 6f 72 65 69 67 6e 2d ").;;; (foreign-
14fb0 64 65 63 6c 61 72 65 20 22 23 69 6e 63 6c 75 64 declare "#includ
14fc0 65 20 5c 22 73 79 73 2f 73 6f 63 6b 65 74 2e 68 e \"sys/socket.h
14fd0 5c 22 22 29 0a 3b 3b 3b 20 28 66 6f 72 65 69 67 \"").;;; (foreig
14fe0 6e 2d 64 65 63 6c 61 72 65 20 22 23 69 6e 63 6c n-declare "#incl
14ff0 75 64 65 20 5c 22 69 66 61 64 64 72 73 2e 68 5c ude \"ifaddrs.h\
15000 22 22 29 0a 3b 3b 3b 20 28 66 6f 72 65 69 67 6e "").;;; (foreign
15010 2d 64 65 63 6c 61 72 65 20 22 23 69 6e 63 6c 75 -declare "#inclu
15020 64 65 20 5c 22 61 72 70 61 2f 69 6e 65 74 2e 68 de \"arpa/inet.h
15030 5c 22 22 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b \"").;;; .;;; ;;
15040 20 67 65 74 20 49 50 20 61 64 64 72 65 73 73 65 get IP addresse
15050 73 20 66 72 6f 6d 20 41 4c 4c 20 69 6e 74 65 72 s from ALL inter
15060 66 61 63 65 73 0a 3b 3b 3b 20 28 64 65 66 69 6e faces.;;; (defin
15070 65 20 67 65 74 2d 61 6c 6c 2d 69 70 73 0a 3b 3b e get-all-ips.;;
15080 3b 20 20 20 28 66 6f 72 65 69 67 6e 2d 73 61 66 ; (foreign-saf
15090 65 2d 6c 61 6d 62 64 61 2a 20 73 63 68 65 6d 65 e-lambda* scheme
150a0 2d 6f 62 6a 65 63 74 20 28 29 0a 3b 3b 3b 20 20 -object ().;;;
150b0 20 20 20 22 0a 3b 3b 3b 20 0a 3b 3b 3b 20 2f 2f ".;;; .;;; //
150c0 20 66 72 6f 6d 20 68 74 74 70 73 3a 2f 2f 73 74 from https://st
150d0 61 63 6b 6f 76 65 72 66 6c 6f 77 2e 63 6f 6d 2f ackoverflow.com/
150e0 71 75 65 73 74 69 6f 6e 73 2f 31 37 39 30 39 34 questions/179094
150f0 30 31 2f 6c 69 6e 75 78 2d 63 2d 67 65 74 2d 64 01/linux-c-get-d
15100 65 66 61 75 6c 74 2d 69 6e 74 65 72 66 61 63 65 efault-interface
15110 73 2d 69 70 2d 61 64 64 72 65 73 73 20 3a 0a 3b s-ip-address :.;
15120 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 ;; .;;; .;;;
15130 20 43 5f 77 6f 72 64 20 6c 73 74 20 3d 20 43 5f C_word lst = C_
15140 53 43 48 45 4d 45 5f 45 4e 44 5f 4f 46 5f 4c 49 SCHEME_END_OF_LI
15150 53 54 2c 20 6c 65 6e 2c 20 73 74 72 2c 20 2a 61 ST, len, str, *a
15160 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 73 74 72 75 ;.;;; // stru
15170 63 74 20 69 66 61 64 64 72 73 20 2a 69 66 61 2c ct ifaddrs *ifa,
15180 20 2a 69 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 73 *i;.;;; // s
15190 74 72 75 63 74 20 73 6f 63 6b 61 64 64 72 20 2a truct sockaddr *
151a0 73 61 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 sa;.;;; .;;;
151b0 20 73 74 72 75 63 74 20 69 66 61 64 64 72 73 20 struct ifaddrs
151c0 2a 20 69 66 41 64 64 72 53 74 72 75 63 74 20 3d * ifAddrStruct =
151d0 20 4e 55 4c 4c 3b 0a 3b 3b 3b 20 20 20 20 20 73 NULL;.;;; s
151e0 74 72 75 63 74 20 69 66 61 64 64 72 73 20 2a 20 truct ifaddrs *
151f0 69 66 61 20 3d 20 4e 55 4c 4c 3b 0a 3b 3b 3b 20 ifa = NULL;.;;;
15200 20 20 20 20 76 6f 69 64 20 2a 20 74 6d 70 41 64 void * tmpAd
15210 64 72 50 74 72 20 3d 20 4e 55 4c 4c 3b 0a 3b 3b drPtr = NULL;.;;
15220 3b 20 0a 3b 3b 3b 20 20 20 20 20 69 66 20 28 20 ; .;;; if (
15230 67 65 74 69 66 61 64 64 72 73 28 26 69 66 41 64 getifaddrs(&ifAd
15240 64 72 53 74 72 75 63 74 29 20 21 3d 20 30 29 0a drStruct) != 0).
15250 3b 3b 3b 20 20 20 20 20 20 20 43 5f 72 65 74 75 ;;; C_retu
15260 72 6e 28 43 5f 53 43 48 45 4d 45 5f 46 41 4c 53 rn(C_SCHEME_FALS
15270 45 29 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 2f 2f 20 E);.;;; .;;; //
15280 20 20 20 66 6f 72 20 28 69 20 3d 20 69 66 61 3b for (i = ifa;
15290 20 69 20 21 3d 20 4e 55 4c 4c 3b 20 69 20 3d 20 i != NULL; i =
152a0 69 2d 3e 69 66 61 5f 6e 65 78 74 29 20 7b 0a 3b i->ifa_next) {.;
152b0 3b 3b 20 20 20 20 20 66 6f 72 20 28 69 66 61 20 ;; for (ifa
152c0 3d 20 69 66 41 64 64 72 53 74 72 75 63 74 3b 20 = ifAddrStruct;
152d0 69 66 61 20 21 3d 20 4e 55 4c 4c 3b 20 69 66 61 ifa != NULL; ifa
152e0 20 3d 20 69 66 61 2d 3e 69 66 61 5f 6e 65 78 74 = ifa->ifa_next
152f0 29 20 7b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 ) {.;;;
15300 69 66 20 28 69 66 61 2d 3e 69 66 61 5f 61 64 64 if (ifa->ifa_add
15310 72 2d 3e 73 61 5f 66 61 6d 69 6c 79 3d 3d 41 46 r->sa_family==AF
15320 5f 49 4e 45 54 29 20 7b 20 2f 2f 20 43 68 65 63 _INET) { // Chec
15330 6b 20 69 74 20 69 73 0a 3b 3b 3b 20 20 20 20 20 k it is.;;;
15340 20 20 20 20 20 20 20 20 2f 2f 20 61 20 76 61 6c // a val
15350 69 64 20 49 50 76 34 20 61 64 64 72 65 73 73 0a id IPv4 address.
15360 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;;
15370 74 6d 70 41 64 64 72 50 74 72 20 3d 20 26 28 28 tmpAddrPtr = &((
15380 73 74 72 75 63 74 20 73 6f 63 6b 61 64 64 72 5f struct sockaddr_
15390 69 6e 20 2a 29 69 66 61 2d 3e 69 66 61 5f 61 64 in *)ifa->ifa_ad
153a0 64 72 29 2d 3e 73 69 6e 5f 61 64 64 72 3b 0a 3b dr)->sin_addr;.;
153b0 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 63 ;; c
153c0 68 61 72 20 61 64 64 72 65 73 73 42 75 66 66 65 har addressBuffe
153d0 72 5b 49 4e 45 54 5f 41 44 44 52 53 54 52 4c 45 r[INET_ADDRSTRLE
153e0 4e 5d 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 N];.;;;
153f0 20 20 20 20 69 6e 65 74 5f 6e 74 6f 70 28 41 46 inet_ntop(AF
15400 5f 49 4e 45 54 2c 20 74 6d 70 41 64 64 72 50 74 _INET, tmpAddrPt
15410 72 2c 20 61 64 64 72 65 73 73 42 75 66 66 65 72 r, addressBuffer
15420 2c 20 49 4e 45 54 5f 41 44 44 52 53 54 52 4c 45 , INET_ADDRSTRLE
15430 4e 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 N);.;;; //
15440 20 20 20 20 20 20 70 72 69 6e 74 66 28 5c 22 25 printf(\"%
15450 73 20 49 50 20 41 64 64 72 65 73 73 20 25 73 5c s IP Address %s\
15460 5c 6e 5c 22 2c 20 69 66 61 2d 3e 69 66 61 5f 6e \n\", ifa->ifa_n
15470 61 6d 65 2c 20 61 64 64 72 65 73 73 42 75 66 66 ame, addressBuff
15480 65 72 29 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 er);.;;;
15490 20 20 20 20 20 6c 65 6e 20 3d 20 73 74 72 6c 65 len = strle
154a0 6e 28 61 64 64 72 65 73 73 42 75 66 66 65 72 29 n(addressBuffer)
154b0 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;.;;;
154c0 20 20 61 20 3d 20 43 5f 61 6c 6c 6f 63 28 43 5f a = C_alloc(C_
154d0 53 49 5a 45 4f 46 5f 50 41 49 52 20 2b 20 43 5f SIZEOF_PAIR + C_
154e0 53 49 5a 45 4f 46 5f 53 54 52 49 4e 47 28 6c 65 SIZEOF_STRING(le
154f0 6e 29 29 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 n));.;;;
15500 20 20 20 20 20 73 74 72 20 3d 20 43 5f 73 74 72 str = C_str
15510 69 6e 67 28 26 61 2c 20 6c 65 6e 2c 20 61 64 64 ing(&a, len, add
15520 72 65 73 73 42 75 66 66 65 72 29 3b 0a 3b 3b 3b ressBuffer);.;;;
15530 20 20 20 20 20 20 20 20 20 20 20 20 20 6c 73 74 lst
15540 20 3d 20 43 5f 61 5f 70 61 69 72 28 26 61 2c 20 = C_a_pair(&a,
15550 73 74 72 2c 20 6c 73 74 29 3b 0a 3b 3b 3b 20 20 str, lst);.;;;
15560 20 20 20 20 20 20 20 7d 20 0a 3b 3b 3b 20 0a 3b } .;;; .;
15570 3b 3b 20 2f 2f 20 20 20 20 20 20 20 20 65 6c 73 ;; // els
15580 65 20 69 66 20 28 69 66 61 2d 3e 69 66 61 5f 61 e if (ifa->ifa_a
15590 64 64 72 2d 3e 73 61 5f 66 61 6d 69 6c 79 3d 3d ddr->sa_family==
155a0 41 46 5f 49 4e 45 54 36 29 20 7b 20 2f 2f 20 43 AF_INET6) { // C
155b0 68 65 63 6b 20 69 74 20 69 73 0a 3b 3b 3b 20 2f heck it is.;;; /
155c0 2f 20 20 20 20 20 20 20 20 20 20 20 20 2f 2f 20 / //
155d0 61 20 76 61 6c 69 64 20 49 50 76 36 20 61 64 64 a valid IPv6 add
155e0 72 65 73 73 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 ress.;;; //
155f0 20 20 20 20 20 20 20 74 6d 70 41 64 64 72 50 74 tmpAddrPt
15600 72 20 3d 20 26 28 28 73 74 72 75 63 74 20 73 6f r = &((struct so
15610 63 6b 61 64 64 72 5f 69 6e 36 20 2a 29 69 66 61 ckaddr_in6 *)ifa
15620 2d 3e 69 66 61 5f 61 64 64 72 29 2d 3e 73 69 6e ->ifa_addr)->sin
15630 36 5f 61 64 64 72 3b 0a 3b 3b 3b 20 2f 2f 20 20 6_addr;.;;; //
15640 20 20 20 20 20 20 20 20 20 20 63 68 61 72 20 61 char a
15650 64 64 72 65 73 73 42 75 66 66 65 72 5b 49 4e 45 ddressBuffer[INE
15660 54 36 5f 41 44 44 52 53 54 52 4c 45 4e 5d 3b 0a T6_ADDRSTRLEN];.
15670 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 20 20 20 ;;; //
15680 20 20 69 6e 65 74 5f 6e 74 6f 70 28 41 46 5f 49 inet_ntop(AF_I
15690 4e 45 54 36 2c 20 74 6d 70 41 64 64 72 50 74 72 NET6, tmpAddrPtr
156a0 2c 20 61 64 64 72 65 73 73 42 75 66 66 65 72 2c , addressBuffer,
156b0 20 49 4e 45 54 36 5f 41 44 44 52 53 54 52 4c 45 INET6_ADDRSTRLE
156c0 4e 29 3b 0a 3b 3b 3b 20 2f 2f 2f 2f 20 20 20 20 N);.;;; ////
156d0 20 20 20 20 20 20 20 20 70 72 69 6e 74 66 28 5c printf(\
156e0 22 25 73 20 49 50 20 41 64 64 72 65 73 73 20 25 "%s IP Address %
156f0 73 5c 5c 6e 5c 22 2c 20 69 66 61 2d 3e 69 66 61 s\\n\", ifa->ifa
15700 5f 6e 61 6d 65 2c 20 61 64 64 72 65 73 73 42 75 _name, addressBu
15710 66 66 65 72 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 ffer);.;;; //
15720 20 20 20 20 20 20 20 20 20 6c 65 6e 20 3d 20 73 len = s
15730 74 72 6c 65 6e 28 61 64 64 72 65 73 73 42 75 66 trlen(addressBuf
15740 66 65 72 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 fer);.;;; //
15750 20 20 20 20 20 20 20 20 61 20 3d 20 43 5f 61 6c a = C_al
15760 6c 6f 63 28 43 5f 53 49 5a 45 4f 46 5f 50 41 49 loc(C_SIZEOF_PAI
15770 52 20 2b 20 43 5f 53 49 5a 45 4f 46 5f 53 54 52 R + C_SIZEOF_STR
15780 49 4e 47 28 6c 65 6e 29 29 3b 0a 3b 3b 3b 20 2f ING(len));.;;; /
15790 2f 20 20 20 20 20 20 20 20 20 20 20 20 73 74 72 / str
157a0 20 3d 20 43 5f 73 74 72 69 6e 67 28 26 61 2c 20 = C_string(&a,
157b0 6c 65 6e 2c 20 61 64 64 72 65 73 73 42 75 66 66 len, addressBuff
157c0 65 72 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 er);.;;; //
157d0 20 20 20 20 20 20 20 6c 73 74 20 3d 20 43 5f 61 lst = C_a
157e0 5f 70 61 69 72 28 26 61 2c 20 73 74 72 2c 20 6c _pair(&a, str, l
157f0 73 74 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 st);.;;; //
15800 20 20 7d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 2f 2f 20 }.;;; .;;; //
15810 20 20 20 20 20 20 65 6c 73 65 20 7b 0a 3b 3b 3b else {.;;;
15820 20 2f 2f 20 20 20 20 20 20 20 20 20 70 72 69 6e // prin
15830 74 66 28 5c 22 20 6e 6f 74 20 61 6e 20 49 50 76 tf(\" not an IPv
15840 34 20 61 64 64 72 65 73 73 5c 5c 6e 5c 22 29 3b 4 address\\n\");
15850 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 7d 0a .;;; // }.
15860 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 7d 0a 3b ;;; .;;; }.;
15870 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 66 72 65 65 ;; .;;; free
15880 69 66 61 64 64 72 73 28 69 66 61 29 3b 0a 3b 3b ifaddrs(ifa);.;;
15890 3b 20 20 20 20 20 43 5f 72 65 74 75 72 6e 28 6c ; C_return(l
158a0 73 74 29 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 22 29 st);.;;; .;;; ")
158b0 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 43 68 ).;;; .;;; ;; Ch
158c0 61 6e 67 65 20 74 68 69 73 20 74 6f 20 62 69 61 ange this to bia
158d0 73 20 66 6f 72 20 61 64 64 72 65 73 73 65 73 20 s for addresses
158e0 77 69 74 68 20 61 20 72 65 61 73 6f 6e 61 62 6c with a reasonabl
158f0 65 20 62 72 6f 61 64 63 61 73 74 20 76 61 6c 75 e broadcast valu
15900 65 3f 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 e?.;;; ;;.;;; (d
15910 65 66 69 6e 65 20 28 69 70 2d 70 72 65 66 2d 6c efine (ip-pref-l
15920 65 73 73 3f 20 61 20 62 29 0a 3b 3b 3b 20 20 20 ess? a b).;;;
15930 28 6c 65 74 2a 20 28 28 72 61 74 65 20 28 6c 61 (let* ((rate (la
15940 6d 62 64 61 20 28 69 70 73 74 72 29 0a 3b 3b 3b mbda (ipstr).;;;
15950 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15960 20 20 28 72 65 67 65 78 2d 63 61 73 65 20 69 70 (regex-case ip
15970 73 74 72 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 str.;;;
15980 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15990 20 20 20 20 20 28 20 22 5e 31 32 37 5c 5c 2e 22 ( "^127\\."
159a0 20 5f 20 30 20 29 0a 3b 3b 3b 20 20 20 20 20 20 _ 0 ).;;;
159b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
159c0 20 20 20 20 20 20 20 20 28 20 22 5e 28 31 30 5c ( "^(10\
159d0 5c 2e 30 7c 31 39 32 5c 5c 2e 31 36 38 5c 5c 2e \.0|192\\.168\\.
159e0 29 5c 5c 2e 2e 2a 22 20 5f 20 31 20 29 0a 3b 3b )\\..*" _ 1 ).;;
159f0 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
15a00 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
15a10 20 65 6c 73 65 20 32 20 29 20 29 29 29 29 0a 3b else 2 ) )))).;
15a20 3b 3b 20 20 20 20 20 28 3c 20 28 72 61 74 65 20 ;; (< (rate
15a30 61 29 20 28 72 61 74 65 20 62 29 29 29 29 0a 3b a) (rate b)))).;
15a40 3b 3b 20 20 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 ;; .;;; .;;; (
15a50 64 65 66 69 6e 65 20 28 67 65 74 2d 6d 79 2d 62 define (get-my-b
15a60 65 73 74 2d 61 64 64 72 65 73 73 29 0a 3b 3b 3b est-address).;;;
15a70 20 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d 6d 79 (let ((all-my
15a80 2d 61 64 64 72 65 73 73 65 73 20 28 67 65 74 2d -addresses (get-
15a90 61 6c 6c 2d 69 70 73 29 29 0a 3b 3b 3b 20 20 20 all-ips)).;;;
15aa0 20 20 20 20 20 20 3b 3b 28 61 6c 6c 2d 6d 79 2d ;;(all-my-
15ab0 61 64 64 72 65 73 73 65 73 2d 6f 6c 64 20 28 76 addresses-old (v
15ac0 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 ector->list (hos
15ad0 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 20 tinfo-addresses
15ae0 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 (hostname->hosti
15af0 6e 66 6f 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 nfo (get-host-na
15b00 6d 65 29 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 me))))).;;;
15b10 20 20 20 20 29 0a 3b 3b 3b 20 20 20 20 20 28 63 ).;;; (c
15b20 6f 6e 64 0a 3b 3b 3b 20 20 20 20 20 20 28 28 6e ond.;;; ((n
15b30 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 ull? all-my-addr
15b40 65 73 73 65 73 29 0a 3b 3b 3b 20 20 20 20 20 20 esses).;;;
15b50 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
15b60 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
15b70 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15b80 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f ;; no
15b90 20 69 6e 74 65 72 66 61 63 65 73 3f 0a 3b 3b 3b interfaces?.;;;
15ba0 20 20 20 20 20 20 28 28 65 71 3f 20 28 6c 65 6e ((eq? (len
15bb0 67 74 68 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 gth all-my-addre
15bc0 73 73 65 73 29 20 31 29 0a 3b 3b 3b 20 20 20 20 sses) 1).;;;
15bd0 20 20 20 28 63 61 72 20 61 6c 6c 2d 6d 79 2d 61 (car all-my-a
15be0 64 64 72 65 73 73 65 73 29 29 20 20 20 20 20 20 ddresses))
15bf0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15c00 3b 3b 20 6f 6e 6c 79 20 6f 6e 65 20 74 6f 20 63 ;; only one to c
15c10 68 6f 6f 73 65 20 66 72 6f 6d 2c 20 6a 75 73 74 hoose from, just
15c20 20 67 6f 20 77 69 74 68 20 69 74 0a 3b 3b 3b 20 go with it.;;;
15c30 20 20 20 20 20 0a 3b 3b 3b 20 20 20 20 20 20 28 .;;; (
15c40 65 6c 73 65 0a 3b 3b 3b 20 20 20 20 20 20 20 28 else.;;; (
15c50 63 61 72 20 28 73 6f 72 74 20 61 6c 6c 2d 6d 79 car (sort all-my
15c60 2d 61 64 64 72 65 73 73 65 73 20 69 70 2d 70 72 -addresses ip-pr
15c70 65 66 2d 6c 65 73 73 3f 29 29 29 0a 3b 3b 3b 20 ef-less?))).;;;
15c80 20 20 20 20 20 3b 3b 20 28 65 6c 73 65 20 0a 3b ;; (else .;
15c90 3b 3b 20 20 20 20 20 20 3b 3b 20 20 28 69 70 2d ;; ;; (ip-
15ca0 3e 73 74 72 69 6e 67 20 28 63 61 72 20 28 66 69 >string (car (fi
15cb0 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
15cc0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15cd0 20 20 20 20 20 20 3b 3b 20 74 61 6b 65 20 61 6e ;; take an
15ce0 79 20 62 75 74 20 31 32 37 2e 0a 3b 3b 3b 20 20 y but 127..;;;
15cf0 20 20 20 20 3b 3b 20 20 20 20 09 09 09 20 28 6e ;; ... (n
15d00 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 74 6f ot (eq? (u8vecto
15d10 72 2d 72 65 66 20 78 20 30 29 20 31 32 37 29 29 r-ref x 0) 127))
15d20 29 0a 3b 3b 3b 20 20 20 20 20 20 3b 3b 20 20 20 ).;;; ;;
15d30 20 09 09 20 20 20 20 20 20 20 61 6c 6c 2d 6d 79 .. all-my
15d40 2d 61 64 64 72 65 73 73 65 73 29 29 29 29 0a 3b -addresses)))).;
15d50 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 20 29 29 29 ;; .;;; )))
15d60 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e .;;; .;;; (defin
15d70 65 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 2d 73 e (get-all-ips-s
15d80 6f 72 74 65 64 29 0a 3b 3b 3b 20 20 20 28 73 6f orted).;;; (so
15d90 72 74 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 rt (get-all-ips)
15da0 20 69 70 2d 70 72 65 66 2d 6c 65 73 73 3f 29 29 ip-pref-less?))
15db0 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 0a .;;; .;;; ..