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 20 23 21 6f 70 74 69 6f 6e 61 udata #!optiona
13c0: 6c 20 28 74 72 69 65 73 20 30 29 29 0a 20 20 3b l (tries 0)). ;
13d0: 3b 20 73 65 65 20 69 66 20 77 65 20 61 6c 72 65 ; see if we alre
13e0: 61 64 79 20 68 61 76 65 20 61 20 63 61 70 74 61 ady have a capta
13f0: 69 6e 20 61 6e 64 20 69 66 20 74 68 65 20 6c 65 in and if the le
1400: 61 73 65 20 69 73 20 6f 6b 0a 20 20 28 69 66 20 ase is ok. (if
1410: 28 61 6e 64 20 28 75 64 61 74 2d 63 61 70 74 61 (and (udat-capta
1420: 69 6e 2d 61 64 64 72 65 73 73 20 75 64 61 74 61 in-address udata
1430: 29 0a 09 20 20 20 28 75 64 61 74 2d 63 61 70 74 ).. (udat-capt
1440: 61 69 6e 2d 70 6f 72 74 20 20 20 20 75 64 61 74 ain-port udat
1450: 61 29 0a 09 20 20 20 28 3c 20 28 63 75 72 72 65 a).. (< (curre
1460: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 75 64 61 nt-seconds) (uda
1470: 74 2d 63 61 70 74 61 69 6e 2d 6c 65 61 73 65 20 t-captain-lease
1480: 75 64 61 74 61 29 29 29 0a 20 20 20 20 20 20 75 udata))). u
1490: 64 61 74 61 0a 20 20 20 20 20 20 28 6c 65 74 2a data. (let*
14a0: 20 28 28 63 70 6b 74 73 20 28 67 65 74 2d 61 6c ((cpkts (get-al
14b0: 6c 2d 63 61 70 74 61 69 6e 2d 70 6b 74 73 20 75 l-captain-pkts u
14c0: 64 61 74 61 29 29 20 3b 3b 20 72 65 61 64 20 63 data)) ;; read c
14d0: 61 70 74 61 69 6e 20 70 6b 74 73 0a 09 20 20 20 aptain pkts..
14e0: 20 20 28 63 61 70 74 6e 20 28 67 65 74 2d 77 69 (captn (get-wi
14f0: 6e 6e 69 6e 67 2d 70 6b 74 20 63 70 6b 74 73 29 nning-pkt cpkts)
1500: 29 29 0a 09 28 69 66 20 63 61 70 74 6e 0a 09 20 ))..(if captn..
1510: 20 20 20 28 6c 65 74 2a 20 28 28 70 6f 72 74 20 (let* ((port
1520: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 70 6f (alist-ref 'po
1530: 72 74 20 20 20 63 61 70 74 6e 29 29 0a 09 09 20 rt captn))...
1540: 20 20 28 68 6f 73 74 20 20 20 28 61 6c 69 73 74 (host (alist
1550: 2d 72 65 66 20 27 68 6f 73 74 20 20 20 63 61 70 -ref 'host cap
1560: 74 6e 29 29 0a 09 09 20 20 20 28 69 70 61 64 64 tn))... (ipadd
1570: 72 20 28 61 6c 69 73 74 2d 72 65 66 20 27 69 70 r (alist-ref 'ip
1580: 61 64 64 72 20 63 61 70 74 6e 29 29 0a 09 09 20 addr captn))...
1590: 20 20 28 70 69 64 20 20 20 20 28 61 6c 69 73 74 (pid (alist
15a0: 2d 72 65 66 20 27 70 69 64 20 20 20 20 63 61 70 -ref 'pid cap
15b0: 74 6e 29 29 0a 09 09 20 20 20 28 5a 20 20 20 20 tn))... (Z
15c0: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 5a 20 (alist-ref 'Z
15d0: 20 20 20 20 20 63 61 70 74 6e 29 29 29 0a 09 20 captn)))..
15e0: 20 20 20 20 20 28 75 64 61 74 2d 63 61 70 74 61 (udat-capta
15f0: 69 6e 2d 61 64 64 72 65 73 73 2d 73 65 74 21 20 in-address-set!
1600: 75 64 61 74 61 20 69 70 61 64 64 72 29 0a 09 20 udata ipaddr)..
1610: 20 20 20 20 20 28 75 64 61 74 2d 63 61 70 74 61 (udat-capta
1620: 69 6e 2d 68 6f 73 74 2d 73 65 74 21 20 20 20 20 in-host-set!
1630: 75 64 61 74 61 20 68 6f 73 74 29 0a 09 20 20 20 udata host)..
1640: 20 20 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e (udat-captain
1650: 2d 70 6f 72 74 2d 73 65 74 21 20 20 20 20 75 64 -port-set! ud
1660: 61 74 61 20 70 6f 72 74 29 0a 09 20 20 20 20 20 ata port)..
1670: 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 70 (udat-captain-p
1680: 69 64 2d 73 65 74 21 20 20 20 20 20 75 64 61 74 id-set! udat
1690: 61 20 70 69 64 29 0a 09 20 20 20 20 20 20 28 75 a pid).. (u
16a0: 64 61 74 2d 63 61 70 74 61 69 6e 2d 6c 65 61 73 dat-captain-leas
16b0: 65 2d 73 65 74 21 20 20 20 75 64 61 74 61 20 28 e-set! udata (
16c0: 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e + (current-secon
16d0: 64 73 29 20 31 30 29 29 0a 09 20 20 20 20 20 20 ds) 10))..
16e0: 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 73 (let-values (((s
16f0: 75 63 63 65 73 73 20 70 69 6e 67 74 69 6d 65 29 uccess pingtime)
1700: 28 70 69 6e 67 20 75 64 61 74 61 20 28 63 6f 6e (ping udata (con
1710: 63 20 69 70 61 64 64 72 20 22 3a 22 20 70 6f 72 c ipaddr ":" por
1720: 74 29 29 29 29 0a 09 09 28 69 66 20 73 75 63 63 t))))...(if succ
1730: 65 73 73 0a 09 09 20 20 20 20 75 64 61 74 61 0a ess... udata.
1740: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 .. (begin...
1750: 20 20 20 20 20 28 70 72 69 6e 74 20 22 46 6f 75 (print "Fou
1760: 6e 64 20 75 6e 72 65 61 63 68 61 62 6c 65 20 63 nd unreachable c
1770: 61 70 74 61 69 6e 20 61 74 20 22 20 69 70 61 64 aptain at " ipad
1780: 64 72 20 22 3a 22 20 70 6f 72 74 20 22 2c 20 72 dr ":" port ", r
1790: 65 6d 6f 76 69 6e 67 20 70 6b 74 22 29 0a 09 09 emoving pkt")...
17a0: 20 20 20 20 20 20 28 72 65 6d 6f 76 65 2d 63 61 (remove-ca
17b0: 70 74 61 69 6e 2d 70 6b 74 20 75 64 61 74 61 20 ptain-pkt udata
17c0: 63 61 70 74 6e 29 0a 09 09 20 20 20 20 20 20 28 captn)... (
17d0: 69 66 20 28 3c 20 74 72 69 65 73 20 32 30 29 0a if (< tries 20).
17e0: 09 09 09 20 20 28 66 69 6e 64 2d 6f 72 2d 73 65 ... (find-or-se
17f0: 74 75 70 2d 63 61 70 74 61 69 6e 20 75 64 61 74 tup-captain udat
1800: 61 20 28 2b 20 74 72 69 65 73 20 31 29 29 0a 09 a (+ tries 1))..
1810: 09 09 20 20 23 66 29 29 29 29 29 0a 09 20 20 20 .. #f)))))..
1820: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
1830: 73 65 74 75 70 2d 61 73 2d 63 61 70 74 61 69 6e setup-as-captain
1840: 20 75 64 61 74 61 29 20 20 3b 3b 20 74 68 69 73 udata) ;; this
1850: 20 73 61 76 65 73 20 74 68 65 20 74 68 72 65 61 saves the threa
1860: 64 20 74 6f 20 63 61 70 74 61 69 6e 2d 74 68 72 d to captain-thr
1870: 65 61 64 20 61 6e 64 20 73 74 61 72 74 73 20 74 ead and starts t
1880: 68 65 20 74 68 72 65 61 64 0a 09 20 20 20 20 20 he thread..
1890: 20 28 69 66 20 28 3c 20 74 72 69 65 73 20 32 30 (if (< tries 20
18a0: 29 0a 09 09 20 20 28 66 69 6e 64 2d 6f 72 2d 73 )... (find-or-s
18b0: 65 74 75 70 2d 63 61 70 74 61 69 6e 20 75 64 61 etup-captain uda
18c0: 74 61 20 28 2b 20 74 72 69 65 73 20 31 29 29 0a ta (+ tries 1)).
18d0: 09 09 20 20 23 66 29 29 29 29 29 29 0a 0a 3b 3b .. #f))))))..;;
18e0: 20 63 6f 6e 6e 65 63 74 20 74 6f 20 61 20 73 70 connect to a sp
18f0: 65 63 69 66 69 63 20 64 62 66 69 6c 65 0a 3b 3b ecific dbfile.;;
1900: 20 20 20 2d 20 69 66 20 61 6c 72 65 61 64 79 20 - if already
1910: 63 6f 6e 6e 65 63 74 65 64 20 2d 20 72 65 74 75 connected - retu
1920: 72 6e 20 74 68 65 20 64 62 6f 77 6e 65 72 20 68 rn the dbowner h
1930: 6f 73 74 2d 70 6f 72 74 0a 3b 3b 20 20 20 2d 20 ost-port.;; -
1940: 61 73 6b 20 74 68 65 20 63 61 70 74 61 69 6e 20 ask the captain
1950: 77 68 6f 20 74 6f 20 74 61 6c 6b 20 74 6f 20 66 who to talk to f
1960: 6f 72 20 74 68 69 73 20 64 62 0a 3b 3b 20 20 20 or this db.;;
1970: 2d 20 70 75 74 20 74 68 65 20 65 6e 74 72 79 20 - put the entry
1980: 69 6e 20 74 68 65 20 64 62 6f 77 6e 65 72 73 20 in the dbowners
1990: 68 61 73 68 20 61 73 20 64 62 66 69 6c 65 20 3d hash as dbfile =
19a0: 3e 20 68 6f 73 74 2d 70 6f 72 74 0a 3b 3b 0a 28 > host-port.;;.(
19b0: 64 65 66 69 6e 65 20 28 63 6f 6e 6e 65 63 74 20 define (connect
19c0: 75 64 61 74 61 20 64 62 66 6e 61 6d 65 20 64 62 udata dbfname db
19d0: 74 79 70 65 29 0a 20 20 28 6f 72 20 28 68 61 73 type). (or (has
19e0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
19f0: 75 6c 74 20 28 75 64 61 74 2d 64 62 6f 77 6e 65 ult (udat-dbowne
1a00: 72 73 20 75 64 61 74 61 29 20 64 62 66 6e 61 6d rs udata) dbfnam
1a10: 65 20 23 66 29 0a 20 20 20 20 20 20 28 6c 65 74 e #f). (let
1a20: 2d 76 61 6c 75 65 73 20 28 28 28 73 75 63 63 65 -values (((succe
1a30: 73 73 20 64 62 6f 77 6e 65 72 2d 68 6f 73 74 2d ss dbowner-host-
1a40: 70 6f 72 74 29 28 67 65 74 2d 64 62 2d 6f 77 6e port)(get-db-own
1a50: 65 72 20 75 64 61 74 61 20 64 62 66 6e 61 6d 65 er udata dbfname
1a60: 20 64 62 74 79 70 65 29 29 29 0a 09 28 69 66 20 dbtype)))..(if
1a70: 73 75 63 63 65 73 73 0a 09 20 20 20 20 28 62 65 success.. (be
1a80: 67 69 6e 0a 09 20 20 20 20 20 20 3b 3b 20 6a 75 gin.. ;; ju
1a90: 73 74 20 63 6c 6f 62 62 65 72 20 74 68 65 20 72 st clobber the r
1aa0: 65 63 6f 72 64 2c 20 74 68 69 73 20 69 73 20 74 ecord, this is t
1ab0: 68 65 20 6e 65 77 20 64 61 74 61 20 6e 6f 20 6d he new data no m
1ac0: 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 atter what..
1ad0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
1ae0: 74 21 20 28 75 64 61 74 2d 64 62 6f 77 6e 65 72 t! (udat-dbowner
1af0: 73 20 75 64 61 74 61 29 20 64 62 66 6e 61 6d 65 s udata) dbfname
1b00: 20 64 62 6f 77 6e 65 72 2d 68 6f 73 74 2d 70 6f dbowner-host-po
1b10: 72 74 29 0a 09 20 20 20 20 20 20 64 62 6f 77 6e rt).. dbown
1b20: 65 72 2d 68 6f 73 74 2d 70 6f 72 74 29 0a 09 20 er-host-port)..
1b30: 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 72 65 #f))))..;; re
1b40: 74 75 72 6e 73 3a 20 73 75 63 63 65 73 73 20 70 turns: success p
1b50: 69 6e 67 74 69 6d 65 0a 3b 3b 0a 3b 3b 20 4e 4f ingtime.;;.;; NO
1b60: 54 45 3a 20 63 61 75 73 65 73 20 74 68 65 20 63 TE: causes the c
1b70: 61 6c 6c 65 65 20 74 6f 20 73 74 6f 72 65 20 74 allee to store t
1b80: 68 65 20 69 6e 66 6f 20 6f 6e 20 74 68 69 73 20 he info on this
1b90: 68 6f 73 74 20 61 6c 6f 6e 67 20 77 69 74 68 20 host along with
1ba0: 74 68 65 20 64 62 73 20 74 68 69 73 20 68 6f 73 the dbs this hos
1bb0: 74 20 63 75 72 72 65 6e 74 6c 79 20 6f 77 6e 73 t currently owns
1bc0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 70 69 6e .;;.(define (pin
1bd0: 67 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 g udata host-por
1be0: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 t). (let* ((sta
1bf0: 72 74 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c rt (current-mil
1c00: 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 63 liseconds)).. (c
1c10: 6f 6f 6b 69 65 20 28 6d 61 6b 65 2d 63 6f 6f 6b ookie (make-cook
1c20: 69 65 20 75 64 61 74 61 29 29 0a 09 20 28 64 62 ie udata)).. (db
1c30: 73 20 20 20 20 28 75 64 61 74 2d 6d 79 2d 64 62 s (udat-my-db
1c40: 73 20 75 64 61 74 61 29 29 0a 09 20 28 6d 73 67 s udata)).. (msg
1c50: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
1c60: 72 73 70 65 72 73 65 20 64 62 73 20 22 20 22 29 rsperse dbs " ")
1c70: 29 0a 09 20 28 72 65 73 20 28 73 65 6e 64 20 75 ).. (res (send u
1c80: 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 20 27 data host-port '
1c90: 70 69 6e 67 20 63 6f 6f 6b 69 65 20 6d 73 67 20 ping cookie msg
1ca0: 72 65 74 76 61 6c 3a 20 23 74 29 29 0a 09 20 28 retval: #t)).. (
1cb0: 64 65 6c 74 61 20 28 2d 20 28 63 75 72 72 65 6e delta (- (curren
1cc0: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 t-milliseconds)
1cd0: 73 74 61 72 74 29 29 29 0a 20 20 20 20 28 76 61 start))). (va
1ce0: 6c 75 65 73 20 28 65 71 75 61 6c 3f 20 72 65 73 lues (equal? res
1cf0: 20 63 6f 6f 6b 69 65 29 20 64 65 6c 74 61 29 29 cookie) delta))
1d00: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 3a 20 73 )..;; returns: s
1d10: 75 63 63 65 73 73 20 70 69 6e 67 74 69 6d 65 0a uccess pingtime.
1d20: 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 63 61 75 73 ;;.;; NOTE: caus
1d30: 65 73 20 61 6c 6c 20 72 65 66 65 72 65 6e 63 65 es all reference
1d40: 73 20 74 6f 20 74 68 69 73 20 77 6f 72 6b 65 72 s to this worker
1d50: 20 74 6f 20 62 65 20 77 69 70 65 64 20 6f 75 74 to be wiped out
1d60: 20 69 6e 20 74 68 65 0a 3b 3b 20 63 61 6c 6c 65 in the.;; calle
1d70: 65 20 28 75 73 75 73 61 6c 6c 79 20 74 68 65 20 e (ususally the
1d80: 63 61 70 74 61 69 6e 29 0a 3b 3b 0a 28 64 65 66 captain).;;.(def
1d90: 69 6e 65 20 28 67 6f 6f 64 62 79 65 2d 70 69 6e ine (goodbye-pin
1da0: 67 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 g udata host-por
1db0: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 t). (let* ((sta
1dc0: 72 74 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c rt (current-mil
1dd0: 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 63 liseconds)).. (c
1de0: 6f 6f 6b 69 65 20 28 6d 61 6b 65 2d 63 6f 6f 6b ookie (make-cook
1df0: 69 65 20 75 64 61 74 61 29 29 0a 09 20 28 64 62 ie udata)).. (db
1e00: 73 20 20 20 20 28 75 64 61 74 2d 6d 79 2d 64 62 s (udat-my-db
1e10: 73 20 75 64 61 74 61 29 29 0a 09 20 28 72 65 73 s udata)).. (res
1e20: 20 28 73 65 6e 64 20 75 64 61 74 61 20 68 6f 73 (send udata hos
1e30: 74 2d 70 6f 72 74 20 27 67 6f 6f 64 62 79 65 20 t-port 'goodbye
1e40: 63 6f 6f 6b 69 65 20 22 6e 6f 6d 73 67 22 20 72 cookie "nomsg" r
1e50: 65 74 76 61 6c 3a 20 23 74 29 29 0a 09 20 28 64 etval: #t)).. (d
1e60: 65 6c 74 61 20 28 2d 20 28 63 75 72 72 65 6e 74 elta (- (current
1e70: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 -milliseconds) s
1e80: 74 61 72 74 29 29 29 0a 20 20 20 20 28 76 61 6c tart))). (val
1e90: 75 65 73 20 28 65 71 75 61 6c 3f 20 72 65 73 20 ues (equal? res
1ea0: 63 6f 6f 6b 69 65 29 20 64 65 6c 74 61 29 29 29 cookie) delta)))
1eb0: 0a 0a 28 64 65 66 69 6e 65 20 28 67 6f 6f 64 62 ..(define (goodb
1ec0: 79 65 2d 63 61 70 74 61 69 6e 20 75 64 61 74 61 ye-captain udata
1ed0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 ). (let* ((host
1ee0: 2d 70 6f 72 74 20 28 75 64 61 74 2d 63 61 70 74 -port (udat-capt
1ef0: 61 69 6e 2d 68 6f 73 74 2d 70 6f 72 74 20 75 64 ain-host-port ud
1f00: 61 74 61 29 29 29 0a 20 20 20 20 28 69 66 20 68 ata))). (if h
1f10: 6f 73 74 2d 70 6f 72 74 0a 09 28 67 6f 6f 64 62 ost-port..(goodb
1f20: 79 65 2d 70 69 6e 67 20 75 64 61 74 61 20 68 6f ye-ping udata ho
1f30: 73 74 2d 70 6f 72 74 29 0a 09 28 76 61 6c 75 65 st-port)..(value
1f40: 73 20 23 66 20 2d 31 29 29 29 29 0a 0a 28 64 65 s #f -1))))..(de
1f50: 66 69 6e 65 20 28 67 65 74 2d 64 62 2d 6f 77 6e fine (get-db-own
1f60: 65 72 20 75 64 61 74 61 20 64 62 6e 61 6d 65 20 er udata dbname
1f70: 64 62 74 79 70 65 29 0a 20 20 28 6c 65 74 2a 20 dbtype). (let*
1f80: 28 28 68 6f 73 74 2d 70 6f 72 74 20 28 75 64 61 ((host-port (uda
1f90: 74 2d 63 61 70 74 61 69 6e 2d 68 6f 73 74 2d 70 t-captain-host-p
1fa0: 6f 72 74 20 75 64 61 74 61 29 29 29 0a 20 20 20 ort udata))).
1fb0: 20 28 69 66 20 68 6f 73 74 2d 70 6f 72 74 0a 09 (if host-port..
1fc0: 28 6c 65 74 2a 20 28 28 63 6f 6f 6b 69 65 20 28 (let* ((cookie (
1fd0: 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 75 64 61 74 make-cookie udat
1fe0: 61 29 29 0a 09 20 20 20 20 20 20 20 28 6d 73 67 a)).. (msg
1ff0: 20 20 20 20 23 66 29 20 3b 3b 20 28 63 6f 6e 63 #f) ;; (conc
2000: 20 64 62 6e 61 6d 65 20 22 20 22 20 64 62 74 79 dbname " " dbty
2010: 70 65 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 pe)).. (pa
2020: 72 61 6d 73 20 60 28 2c 64 62 6e 61 6d 65 20 2c rams `(,dbname ,
2030: 64 62 74 79 70 65 29 29 0a 09 20 20 20 20 20 20 dbtype))..
2040: 20 28 72 65 73 20 20 20 20 28 73 65 6e 64 20 75 (res (send u
2050: 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 20 27 data host-port '
2060: 64 62 2d 6f 77 6e 65 72 20 63 6f 6f 6b 69 65 20 db-owner cookie
2070: 6d 73 67 0a 09 09 09 20 20 20 20 20 70 61 72 61 msg.... para
2080: 6d 73 3a 20 70 61 72 61 6d 73 20 72 65 74 76 61 ms: params retva
2090: 6c 3a 20 23 74 29 29 29 0a 09 20 20 28 6d 61 74 l: #t))).. (mat
20a0: 63 68 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 ch (string-split
20b0: 20 72 65 73 29 0a 09 20 20 20 20 28 28 72 65 74 res).. ((ret
20c0: 63 6f 6f 6b 69 65 20 6f 77 6e 65 72 2d 68 6f 73 cookie owner-hos
20d0: 74 2d 70 6f 72 74 29 0a 09 20 20 20 20 20 28 76 t-port).. (v
20e0: 61 6c 75 65 73 20 28 65 71 75 61 6c 3f 20 72 65 alues (equal? re
20f0: 74 63 6f 6f 6b 69 65 20 63 6f 6f 6b 69 65 29 20 tcookie cookie)
2100: 6f 77 6e 65 72 2d 68 6f 73 74 2d 70 6f 72 74 29 owner-host-port)
2110: 29 29 29 0a 09 28 76 61 6c 75 65 73 20 23 66 20 )))..(values #f
2120: 2d 31 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 65 -1))))..;; calle
2130: 64 20 69 6e 20 75 6c 65 78 2d 68 61 6e 64 6c 65 d in ulex-handle
2140: 72 20 74 6f 20 64 69 73 70 61 74 63 68 20 77 6f r to dispatch wo
2150: 72 6b 2c 20 63 61 6c 6c 65 64 20 6f 6e 20 74 68 rk, called on th
2160: 65 20 77 6f 72 6b 65 72 73 20 73 69 64 65 0a 3b e workers side.;
2170: 3b 20 20 20 20 20 63 61 6c 6c 73 20 28 70 72 6f ; calls (pro
2180: 63 20 70 61 72 61 6d 73 20 64 61 74 61 29 0a 3b c params data).;
2190: 3b 20 20 20 20 20 72 65 74 75 72 6e 73 20 72 65 ; returns re
21a0: 73 75 6c 74 20 77 69 74 68 20 63 6f 6f 6b 69 65 sult with cookie
21b0: 0a 3b 3b 0a 3b 3b 20 70 64 61 74 20 69 73 20 74 .;;.;; pdat is t
21c0: 68 65 20 69 6e 66 6f 20 6f 66 20 74 68 65 20 63 he info of the c
21d0: 61 6c 6c 65 72 2c 20 75 73 65 64 20 74 6f 20 73 aller, used to s
21e0: 65 6e 64 20 74 68 65 20 72 65 73 75 6c 74 20 64 end the result d
21f0: 61 74 61 0a 3b 3b 20 70 72 6f 63 6b 65 79 20 69 ata.;; prockey i
2200: 73 20 6b 65 79 20 69 6e 74 6f 20 75 64 61 74 2d s key into udat-
2210: 68 61 6e 64 6c 65 72 73 20 68 61 73 68 20 64 65 handlers hash de
2220: 72 65 66 65 72 65 6e 63 69 6e 67 20 61 20 70 72 referencing a pr
2230: 6f 63 0a 3b 3b 20 70 72 6f 63 70 61 72 61 6d 20 oc.;; procparam
2240: 69 73 20 61 20 66 69 72 73 74 20 70 61 72 61 6d is a first param
2250: 20 68 61 6e 64 65 64 20 74 6f 20 70 72 6f 63 20 handed to proc
2260: 2d 20 6f 66 74 65 6e 20 74 6f 20 64 6f 20 66 75 - often to do fu
2270: 72 74 68 65 72 20 64 65 72 65 66 72 65 6e 63 69 rther derefrenci
2280: 6e 67 0a 3b 3b 20 4e 4f 54 45 3a 20 70 61 72 61 ng.;; NOTE: para
2290: 6d 73 20 69 73 20 69 6e 74 65 6e 64 65 64 20 74 ms is intended t
22a0: 6f 20 62 65 20 61 20 6c 69 73 74 20 6f 66 20 73 o be a list of s
22b0: 74 72 69 6e 67 73 2c 20 65 6e 63 6f 64 69 6e 67 trings, encoding
22c0: 20 6f 6e 20 64 61 74 61 0a 3b 3b 20 20 20 20 20 on data.;;
22d0: 20 20 69 73 20 75 70 20 74 6f 20 74 68 65 20 75 is up to the u
22e0: 73 65 72 20 62 75 74 20 64 61 74 61 20 6d 75 73 ser but data mus
22f0: 74 20 62 65 20 61 20 73 69 6e 67 6c 65 20 6c 69 t be a single li
2300: 6e 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 70 ne.;;.(define (p
2310: 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 20 75 rocess-request u
2320: 64 61 74 61 20 70 64 61 74 20 64 62 6e 61 6d 65 data pdat dbname
2330: 20 63 6f 6f 6b 69 65 20 70 72 6f 63 6b 65 79 20 cookie prockey
2340: 70 72 6f 63 70 61 72 61 6d 20 64 61 74 61 29 0a procparam data).
2350: 20 20 28 6c 65 74 2a 20 28 28 64 62 72 65 63 20 (let* ((dbrec
2360: 28 75 6c 65 78 2d 6f 70 65 6e 2d 64 62 20 75 64 (ulex-open-db ud
2370: 61 74 61 20 64 62 6e 61 6d 65 29 29 20 20 20 20 ata dbname))
2380: 20 3b 3b 20 74 68 69 73 20 77 69 6c 6c 20 62 65 ;; this will be
2390: 20 61 20 64 62 63 6f 6e 6e 20 72 65 63 6f 72 64 a dbconn record
23a0: 2c 20 6c 6f 6f 6b 73 20 66 6f 72 20 69 6e 20 75 , looks for in u
23b0: 64 61 74 61 20 66 69 72 73 74 0a 09 20 28 70 72 data first.. (pr
23c0: 6f 63 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d oc (hash-table-
23d0: 72 65 66 20 75 64 61 74 61 20 70 72 6f 63 6b 65 ref udata procke
23e0: 79 29 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 y))). (let* (
23f0: 28 72 65 73 75 6c 74 20 28 70 72 6f 63 20 64 62 (result (proc db
2400: 72 65 63 20 70 72 6f 63 70 61 72 61 6d 20 64 61 rec procparam da
2410: 74 61 29 29 29 0a 20 20 20 20 20 20 72 65 73 75 ta))). resu
2420: 6c 74 29 29 29 0a 0a 3b 3b 20 72 65 6d 6f 74 65 lt)))..;; remote
2430: 2d 72 65 71 75 65 73 74 20 2d 20 73 65 6e 64 20 -request - send
2440: 74 6f 20 72 65 6d 6f 74 65 20 74 6f 20 70 72 6f to remote to pro
2450: 63 65 73 73 20 69 6e 20 70 72 6f 63 65 73 73 2d cess in process-
2460: 72 65 71 75 65 73 74 0a 3b 3b 20 75 63 6f 6e 6e request.;; uconn
2470: 20 63 6f 6d 65 73 20 66 72 6f 6d 20 61 20 63 61 comes from a ca
2480: 6c 6c 20 74 6f 20 63 6f 6e 6e 65 63 74 20 61 6e ll to connect an
2490: 64 20 63 61 6e 20 62 65 20 75 73 65 64 20 69 6e d can be used in
24a0: 73 74 65 61 64 20 6f 66 20 63 61 6c 6c 69 6e 67 stead of calling
24b0: 20 63 6f 6e 6e 65 63 74 20 61 67 61 69 6e 0a 3b connect again.;
24c0: 3b 20 75 63 6f 6e 6e 20 69 73 20 74 68 65 20 68 ; uconn is the h
24d0: 6f 73 74 2d 70 6f 72 74 20 74 6f 20 63 61 6c 6c ost-port to call
24e0: 0a 3b 3b 20 77 65 20 73 65 6e 64 20 64 62 6e 61 .;; we send dbna
24f0: 6d 65 20 74 6f 20 74 68 65 20 77 6f 72 6b 65 72 me to the worker
2500: 20 73 6f 20 74 68 65 79 20 6b 6e 6f 77 20 77 68 so they know wh
2510: 69 63 68 20 66 69 6c 65 20 74 6f 20 6f 70 65 6e ich file to open
2520: 0a 3b 3b 20 64 61 74 61 20 6d 75 73 74 20 62 65 .;; data must be
2530: 20 61 20 73 74 72 69 6e 67 20 77 69 74 68 20 6e a string with n
2540: 6f 20 6e 65 77 6c 69 6e 65 73 2c 20 69 74 20 77 o newlines, it w
2550: 69 6c 6c 20 62 65 20 68 61 6e 64 65 64 20 74 6f ill be handed to
2560: 20 74 68 65 20 70 72 6f 63 0a 3b 3b 20 61 74 20 the proc.;; at
2570: 74 68 65 20 72 65 6d 6f 74 65 20 73 69 74 65 20 the remote site
2580: 75 6e 63 68 61 6e 67 65 64 2e 20 49 74 20 69 73 unchanged. It is
2590: 20 75 70 20 74 6f 20 74 68 65 20 75 73 65 72 20 up to the user
25a0: 74 6f 20 65 6e 63 6f 64 65 2f 64 65 63 6f 64 65 to encode/decode
25b0: 20 69 74 27 73 20 63 6f 6e 74 65 6e 74 73 0a 3b it's contents.;
25c0: 3b 0a 3b 3b 20 20 20 72 74 79 70 65 3a 20 69 6d ;.;; rtype: im
25d0: 6d 65 64 69 61 74 65 2c 20 72 65 61 64 2d 6f 6e mediate, read-on
25e0: 6c 79 2c 20 6e 6f 72 6d 61 6c 2c 20 6c 6f 77 2d ly, normal, low-
25f0: 70 72 69 6f 72 69 74 79 0a 3b 3b 20 0a 28 64 65 priority.;; .(de
2600: 66 69 6e 65 20 28 72 65 6d 6f 74 65 2d 72 65 71 fine (remote-req
2610: 75 65 73 74 20 75 64 61 74 61 20 75 63 6f 6e 6e uest udata uconn
2620: 20 72 74 79 70 65 20 64 62 6e 61 6d 65 20 70 72 rtype dbname pr
2630: 6f 63 6b 65 79 20 70 72 6f 63 70 61 72 61 6d 20 ockey procparam
2640: 64 61 74 61 29 0a 20 20 28 6c 65 74 2a 20 28 28 data). (let* ((
2650: 63 6f 6f 6b 69 65 20 20 20 20 28 6d 61 6b 65 2d cookie (make-
2660: 63 6f 6f 6b 69 65 20 75 64 61 74 61 29 29 29 0a cookie udata))).
2670: 20 20 20 20 28 73 65 6e 64 2d 72 65 63 65 69 76 (send-receiv
2680: 65 20 75 64 61 74 61 20 75 63 6f 6e 6e 20 72 74 e udata uconn rt
2690: 79 70 65 20 63 6f 6f 6b 69 65 20 64 61 74 61 20 ype cookie data
26a0: 60 28 2c 70 72 6f 63 6b 65 79 20 70 72 6f 63 70 `(,prockey procp
26b0: 61 72 61 6d 29 29 29 29 0a 0a 28 64 65 66 69 6e aram))))..(defin
26c0: 65 20 28 75 6c 65 78 2d 6f 70 65 6e 2d 64 62 20 e (ulex-open-db
26d0: 75 64 61 74 61 20 64 62 6e 61 6d 65 29 0a 20 20 udata dbname).
26e0: 23 66 29 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d #f)...;;========
26f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
2730: 3b 20 55 6c 65 78 20 64 62 0a 3b 3b 0a 3b 3b 20 ; Ulex db.;;.;;
2740: 20 20 2d 20 74 72 61 63 6b 20 77 68 6f 20 69 73 - track who is
2750: 20 63 61 70 74 61 69 6e 2c 20 6c 65 61 73 65 20 captain, lease
2760: 65 78 70 69 72 65 20 74 69 6d 65 0a 3b 3b 20 20 expire time.;;
2770: 20 2d 20 74 72 61 63 6b 20 77 68 6f 20 6f 77 6e - track who own
2780: 73 20 77 68 61 74 20 64 62 2c 20 6c 65 61 73 65 s what db, lease
2790: 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;.;;==========
27a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
27e0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 75 6c 65 .;;.(define (ule
27f0: 78 2d 64 62 66 6e 61 6d 65 29 0a 20 20 28 6c 65 x-dbfname). (le
2800: 74 20 28 28 64 62 64 69 72 20 28 63 6f 6e 63 20 t ((dbdir (conc
2810: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
2820: 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 22 -variable "HOME"
2830: 29 20 22 2f 2e 75 6c 65 78 22 29 29 29 0a 20 20 ) "/.ulex"))).
2840: 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 (if (not (file
2850: 2d 65 78 69 73 74 73 3f 20 64 62 64 69 72 29 29 -exists? dbdir))
2860: 0a 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 ..(create-direct
2870: 6f 72 79 20 64 62 64 69 72 20 23 74 29 29 0a 20 ory dbdir #t)).
2880: 20 20 20 28 63 6f 6e 63 20 64 62 64 69 72 20 22 (conc dbdir "
2890: 2f 6e 65 74 77 6f 72 6b 2e 64 62 22 29 29 29 0a /network.db"))).
28a0: 09 20 0a 3b 3b 20 61 6c 77 61 79 73 20 67 6f 65 . .;; always goe
28b0: 73 20 69 6e 20 7e 2f 2e 75 6c 65 78 2f 6e 65 74 s in ~/.ulex/net
28c0: 77 6f 72 6b 2e 64 62 0a 3b 3b 20 72 6f 6c 65 20 work.db.;; role
28d0: 69 73 20 63 61 70 74 61 69 6e 2c 20 61 64 6a 75 is captain, adju
28e0: 74 61 6e 74 2c 20 6e 6f 64 65 0a 3b 3b 0a 28 64 tant, node.;;.(d
28f0: 65 66 69 6e 65 20 28 75 6c 65 78 64 62 2d 73 65 efine (ulexdb-se
2900: 74 75 70 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 tup). (let* ((d
2910: 62 66 6e 61 6d 65 20 28 75 6c 65 78 2d 64 62 66 bfname (ulex-dbf
2920: 6e 61 6d 65 29 29 0a 09 20 28 68 61 76 65 2d 64 name)).. (have-d
2930: 62 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 b (file-exists?
2940: 64 62 66 6e 61 6d 65 29 29 0a 09 20 28 64 62 20 dbfname)).. (db
2950: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 6f 70 (sqlite3:op
2960: 65 6e 2d 64 61 74 61 62 61 73 65 20 64 62 66 6e en-database dbfn
2970: 61 6d 65 29 29 29 0a 20 20 20 20 28 73 71 6c 69 ame))). (sqli
2980: 74 65 33 3a 73 65 74 2d 62 75 73 79 2d 68 61 6e te3:set-busy-han
2990: 64 6c 65 72 21 20 64 62 20 28 73 71 6c 69 74 65 dler! db (sqlite
29a0: 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 69 6d 65 3:make-busy-time
29b0: 6f 75 74 20 31 33 36 30 30 30 29 29 0a 20 20 20 out 136000)).
29c0: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
29d0: 65 20 64 62 20 22 50 52 41 47 4d 41 20 73 79 6e e db "PRAGMA syn
29e0: 63 68 72 6f 6e 6f 75 73 20 3d 20 30 3b 22 29 0a chronous = 0;").
29f0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 68 61 76 (if (not hav
2a00: 65 2d 64 62 29 0a 09 28 73 71 6c 69 74 65 33 3a e-db)..(sqlite3:
2a10: 77 69 74 68 2d 74 72 61 6e 73 61 63 74 69 6f 6e with-transaction
2a20: 0a 09 20 64 62 0a 09 20 28 6c 61 6d 62 64 61 20 .. db.. (lambda
2a30: 28 29 0a 09 20 20 20 28 66 6f 72 2d 65 61 63 68 ().. (for-each
2a40: 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 .. (lambda (s
2a50: 74 6d 74 29 0a 09 20 20 20 20 20 20 28 69 66 20 tmt).. (if
2a60: 73 74 6d 74 20 28 73 71 6c 69 74 65 33 3a 65 78 stmt (sqlite3:ex
2a70: 65 63 75 74 65 20 64 62 20 73 74 6d 74 29 29 29 ecute db stmt)))
2a80: 0a 09 20 20 20 20 60 28 22 43 52 45 41 54 45 20 .. `("CREATE
2a90: 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 TABLE IF NOT EXI
2aa0: 53 54 53 20 6e 6f 64 65 73 0a 20 20 20 20 20 20 STS nodes.
2ab0: 20 20 20 20 20 20 20 20 20 20 20 28 69 64 20 49 (id I
2ac0: 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b NTEGER PRIMARY K
2ad0: 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 EY,.
2ae0: 20 20 20 20 20 20 72 6f 6c 65 20 20 54 45 58 54 role TEXT
2af0: 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 NOT NULL,.
2b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 6f 73 hos
2b10: 74 20 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c t TEXT NOT NULL
2b20: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,.
2b30: 20 20 20 20 70 6f 72 74 20 54 45 58 54 20 4e 4f port TEXT NO
2b40: 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 T NULL,.
2b50: 20 20 20 20 20 20 20 20 20 20 69 70 61 64 72 20 ipadr
2b60: 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 TEXT NOT NULL,.
2b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b80: 20 70 69 64 20 20 20 49 4e 54 45 47 45 52 20 4e pid INTEGER N
2b90: 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 OT NULL,.
2ba0: 20 20 20 20 20 20 20 20 20 20 20 7a 63 61 72 64 zcard
2bb0: 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a TEXT NOT NULL,.
2bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bd0: 20 20 72 65 67 74 69 6d 65 20 49 4e 54 45 47 45 regtime INTEGE
2be0: 52 20 44 45 46 41 55 4c 54 20 28 73 74 72 66 74 R DEFAULT (strft
2bf0: 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 ime('%s','now'))
2c00: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,.
2c10: 20 20 20 20 6c 65 61 73 65 5f 74 68 72 75 20 49 lease_thru I
2c20: 4e 54 45 47 45 52 20 44 45 46 41 55 4c 54 20 28 NTEGER DEFAULT (
2c30: 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
2c40: 6f 77 27 29 29 2c 0a 20 20 20 20 20 20 20 20 20 ow')),.
2c50: 20 20 20 20 20 20 20 20 20 6c 61 73 74 5f 75 70 last_up
2c60: 64 61 74 65 20 49 4e 54 45 47 45 52 20 44 45 46 date INTEGER DEF
2c70: 41 55 4c 54 20 28 73 74 72 66 74 69 6d 65 28 27 AULT (strftime('
2c80: 25 73 27 2c 27 6e 6f 77 27 29 29 29 3b 22 0a 09 %s','now')));"..
2c90: 20 20 20 20 20 20 22 43 52 45 41 54 45 20 54 52 "CREATE TR
2ca0: 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 58 IGGER IF NOT EX
2cb0: 49 53 54 53 20 75 70 64 61 74 65 5f 6e 6f 64 65 ISTS update_node
2cc0: 73 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 20 s_trigger AFTER
2cd0: 55 50 44 41 54 45 20 4f 4e 20 6e 6f 64 65 73 0a UPDATE ON nodes.
2ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 46 4f 52 FOR
2d00: 20 45 41 43 48 20 52 4f 57 0a 20 20 20 20 20 20 EACH ROW.
2d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d20: 20 20 20 20 20 20 20 20 20 42 45 47 49 4e 20 0a BEGIN .
2d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d50: 20 55 50 44 41 54 45 20 6e 6f 64 65 73 20 53 45 UPDATE nodes SE
2d60: 54 20 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 73 T last_update=(s
2d70: 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f trftime('%s','no
2d80: 77 27 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 w')).
2d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2da0: 20 20 20 20 20 20 20 20 57 48 45 52 45 20 69 64 WHERE id
2db0: 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 =old.id;.
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2dd0: 20 20 20 20 20 20 20 20 45 4e 44 3b 22 0a 09 20 END;"..
2de0: 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 "CREATE TAB
2df0: 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 LE IF NOT EXISTS
2e00: 20 64 62 73 0a 20 20 20 20 20 20 20 20 20 20 20 dbs.
2e10: 20 20 20 20 20 20 28 69 64 20 49 4e 54 45 47 45 (id INTEGE
2e20: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 R PRIMARY KEY,.
2e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e40: 20 64 62 6e 61 6d 65 20 54 45 58 54 20 4e 4f 54 dbname TEXT NOT
2e50: 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 NULL,.
2e60: 20 20 20 20 20 20 20 20 20 64 62 66 69 6c 65 20 dbfile
2e70: 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 TEXT NOT NULL,.
2e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e90: 20 64 62 74 79 70 65 20 54 45 58 54 20 4e 4f 54 dbtype TEXT NOT
2ea0: 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 NULL,.
2eb0: 20 20 20 20 20 20 20 20 20 68 6f 73 74 5f 70 6f host_po
2ec0: 72 74 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c rt TEXT NOT NULL
2ed0: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,.
2ee0: 20 20 20 20 72 65 67 74 69 6d 65 20 49 4e 54 45 regtime INTE
2ef0: 47 45 52 20 44 45 46 41 55 4c 54 20 28 73 74 72 GER DEFAULT (str
2f00: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
2f10: 29 29 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 )),.
2f20: 20 20 20 20 20 20 6c 65 61 73 65 5f 74 68 72 75 lease_thru
2f30: 20 49 4e 54 45 47 45 52 20 44 45 46 41 55 4c 54 INTEGER DEFAULT
2f40: 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c (strftime('%s',
2f50: 27 6e 6f 77 27 29 29 2c 0a 20 20 20 20 20 20 20 'now')),.
2f60: 20 20 20 20 20 20 20 20 20 20 20 6c 61 73 74 5f last_
2f70: 75 70 64 61 74 65 20 49 4e 54 45 47 45 52 20 44 update INTEGER D
2f80: 45 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d 65 EFAULT (strftime
2f90: 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 29 3b 22 ('%s','now')));"
2fa0: 0a 09 20 20 20 20 20 20 22 43 52 45 41 54 45 20 .. "CREATE
2fb0: 54 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 TRIGGER IF NOT
2fc0: 45 58 49 53 54 53 20 75 70 64 61 74 65 5f 64 62 EXISTS update_db
2fd0: 73 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 20 s_trigger AFTER
2fe0: 55 50 44 41 54 45 20 4f 4e 20 64 62 73 0a 20 20 UPDATE ON dbs.
2ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3000: 20 20 20 20 20 20 20 20 20 20 20 46 4f 52 20 45 FOR E
3010: 41 43 48 20 52 4f 57 0a 20 20 20 20 20 20 20 20 ACH ROW.
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 42 45 47 49 4e 20 0a 20 20 BEGIN .
3040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 55 U
3060: 50 44 41 54 45 20 64 62 73 20 53 45 54 20 6c 61 PDATE dbs SET la
3070: 73 74 5f 75 70 64 61 74 65 3d 28 73 74 72 66 74 st_update=(strft
3080: 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 ime('%s','now'))
3090: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
30a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30b0: 20 20 20 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 WHERE id=old
30c0: 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 20 20 20 .id;.
30d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30e0: 20 20 20 20 45 4e 44 3b 22 29 29 29 29 29 0a 20 END;"))))).
30f0: 20 20 20 64 62 29 29 0a 0a 28 64 65 66 69 6e 65 db))..(define
3100: 20 28 67 65 74 2d 68 6f 73 74 2d 70 6f 72 74 2d (get-host-port-
3110: 6c 65 61 73 65 20 64 62 20 64 62 66 6e 61 6d 65 lease db dbfname
3120: 29 0a 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 6c ). (sqlite3:fol
3130: 64 2d 72 6f 77 0a 20 20 20 28 6c 61 6d 62 64 61 d-row. (lambda
3140: 20 28 72 65 6d 20 68 6f 73 74 2d 70 6f 72 74 20 (rem host-port
3150: 6c 65 61 73 65 2d 74 68 72 75 29 0a 20 20 20 20 lease-thru).
3160: 20 28 6c 69 73 74 20 68 6f 73 74 2d 70 6f 72 74 (list host-port
3170: 20 6c 65 61 73 65 2d 74 68 72 75 29 29 0a 20 20 lease-thru)).
3180: 20 23 66 20 64 62 20 22 53 45 4c 45 43 54 20 68 #f db "SELECT h
3190: 6f 73 74 5f 70 6f 72 74 2c 6c 65 61 73 65 5f 74 ost_port,lease_t
31a0: 68 72 75 20 46 52 4f 4d 20 64 62 73 20 57 48 45 hru FROM dbs WHE
31b0: 52 45 20 64 62 66 69 6c 65 20 3d 20 3f 22 20 64 RE dbfile = ?" d
31c0: 62 66 6e 61 6d 65 29 29 0a 20 20 0a 28 64 65 66 bfname)). .(def
31d0: 69 6e 65 20 28 72 65 67 69 73 74 65 72 2d 63 61 ine (register-ca
31e0: 70 74 61 69 6e 20 64 62 20 68 6f 73 74 20 69 70 ptain db host ip
31f0: 61 64 72 20 70 6f 72 74 20 70 69 64 20 7a 63 61 adr port pid zca
3200: 72 64 20 23 21 6b 65 79 20 28 6c 65 61 73 65 20 rd #!key (lease
3210: 32 30 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 20)). (let* ((d
3220: 62 66 6e 61 6d 65 20 28 75 6c 65 78 2d 64 62 66 bfname (ulex-dbf
3230: 6e 61 6d 65 29 29 0a 09 20 28 68 6f 73 74 2d 70 name)).. (host-p
3240: 6f 72 74 20 20 28 63 6f 6e 63 20 68 6f 73 74 20 ort (conc host
3250: 22 3a 22 20 70 6f 72 74 29 29 29 0a 20 20 20 20 ":" port))).
3260: 28 73 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 (sqlite3:with-tr
3270: 61 6e 73 61 63 74 69 6f 6e 0a 20 20 20 20 20 64 ansaction. d
3280: 62 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 b. (lambda (
3290: 29 0a 20 20 20 20 20 20 20 28 6d 61 74 63 68 20 ). (match
32a0: 28 67 65 74 2d 68 6f 73 74 2d 70 6f 72 74 2d 6c (get-host-port-l
32b0: 65 61 73 65 20 64 62 20 64 62 66 6e 61 6d 65 29 ease db dbfname)
32c0: 0a 09 20 28 28 68 6f 73 74 2d 70 6f 72 74 20 6c .. ((host-port l
32d0: 65 61 73 65 2d 74 68 72 75 29 0a 09 20 20 28 69 ease-thru).. (i
32e0: 66 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 f (> (current-se
32f0: 63 6f 6e 64 73 29 20 6c 65 61 73 65 2d 74 68 72 conds) lease-thr
3300: 75 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e u).. (begin
3310: 0a 09 09 28 73 71 6c 69 74 65 33 3a 65 78 65 63 ...(sqlite3:exec
3320: 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 64 ute db "UPDATE d
3330: 62 73 20 53 45 54 20 68 6f 73 74 5f 70 6f 72 74 bs SET host_port
3340: 3d 3f 2c 6c 65 61 73 65 5f 74 68 72 75 3d 3f 20 =?,lease_thru=?
3350: 57 48 45 52 45 20 64 62 6e 61 6d 65 3d 3f 22 0a WHERE dbname=?".
3360: 09 09 09 09 20 28 63 6f 6e 63 20 68 6f 73 74 20 .... (conc host
3370: 22 3a 22 20 70 6f 72 74 29 0a 09 09 09 09 20 28 ":" port)..... (
3380: 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e + (current-secon
3390: 64 73 29 20 6c 65 61 73 65 29 0a 09 09 09 09 20 ds) lease).....
33a0: 64 62 66 6e 61 6d 65 29 0a 09 09 23 74 29 0a 09 dbfname)...#t)..
33b0: 20 20 20 20 20 20 23 66 29 29 0a 09 20 28 23 66 #f)).. (#f
33c0: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
33d0: 74 65 20 64 62 20 22 49 4e 53 45 52 54 20 49 4e te db "INSERT IN
33e0: 54 4f 20 64 62 73 20 28 64 62 6e 61 6d 65 2c 64 TO dbs (dbname,d
33f0: 62 66 69 6c 65 2c 64 62 74 79 70 65 2c 68 6f 73 bfile,dbtype,hos
3400: 74 5f 70 6f 72 74 2c 6c 65 61 73 65 5f 74 68 72 t_port,lease_thr
3410: 75 29 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f u) VALUES (?,?,?
3420: 2c 3f 2c 3f 29 22 0a 09 09 09 20 20 20 20 20 20 ,?,?)"....
3430: 20 22 63 61 70 74 61 69 6e 22 20 64 62 66 6e 61 "captain" dbfna
3440: 6d 65 20 22 63 61 70 74 61 69 6e 22 20 68 6f 73 me "captain" hos
3450: 74 2d 70 6f 72 74 20 28 2b 20 28 63 75 72 72 65 t-port (+ (curre
3460: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 65 61 73 nt-seconds) leas
3470: 65 29 29 29 0a 09 20 28 65 6c 73 65 20 28 70 72 e))).. (else (pr
3480: 69 6e 74 20 22 45 52 52 4f 52 3a 20 55 6e 72 65 int "ERROR: Unre
3490: 63 6f 67 6e 69 73 65 64 20 72 65 73 75 6c 74 20 cognised result
34a0: 66 72 6f 6d 20 66 6f 6c 64 2d 72 6f 77 22 29 0a from fold-row").
34b0: 09 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 . (exit 1)
34c0: 29 29 29 29 29 29 0a 09 09 09 09 09 09 09 20 20 ))))))........
34d0: 20 20 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d ================
3510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 6e ===========.;; n
3520: 65 74 77 6f 72 6b 20 75 74 69 6c 69 74 69 65 73 etwork utilities
3530: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
3540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
3580: 6e 65 20 28 72 61 74 65 2d 69 70 20 69 70 61 64 ne (rate-ip ipad
3590: 64 72 29 0a 20 20 28 72 65 67 65 78 2d 63 61 73 dr). (regex-cas
35a0: 65 20 69 70 61 64 64 72 0a 20 20 20 20 28 20 22 e ipaddr. ( "
35b0: 5e 31 32 37 5c 5c 2e 2e 2a 22 20 5f 20 30 20 29 ^127\\..*" _ 0 )
35c0: 0a 20 20 20 20 28 20 22 5e 28 31 30 5c 5c 2e 30 . ( "^(10\\.0
35d0: 7c 31 39 32 5c 5c 2e 31 36 38 29 5c 5c 2e 2e 2a |192\\.168)\\..*
35e0: 22 20 5f 20 31 20 29 0a 20 20 20 20 28 20 65 6c " _ 1 ). ( el
35f0: 73 65 20 32 20 29 20 29 29 0a 0a 3b 3b 20 43 68 se 2 ) ))..;; Ch
3600: 61 6e 67 65 20 74 68 69 73 20 74 6f 20 62 69 61 ange this to bia
3610: 73 20 66 6f 72 20 61 64 64 72 65 73 73 65 73 20 s for addresses
3620: 77 69 74 68 20 61 20 72 65 61 73 6f 6e 61 62 6c with a reasonabl
3630: 65 20 62 72 6f 61 64 63 61 73 74 20 76 61 6c 75 e broadcast valu
3640: 65 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 69 e?.;;.(define (i
3650: 70 2d 70 72 65 66 2d 6c 65 73 73 3f 20 61 20 62 p-pref-less? a b
3660: 29 0a 20 20 28 3e 20 28 72 61 74 65 2d 69 70 20 ). (> (rate-ip
3670: 61 29 20 28 72 61 74 65 2d 69 70 20 62 29 29 29 a) (rate-ip b)))
3680: 0a 20 20 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 . ..(define (ge
3690: 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 73 t-my-best-addres
36a0: 73 29 0a 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d s). (let ((all-
36b0: 6d 79 2d 61 64 64 72 65 73 73 65 73 20 28 67 65 my-addresses (ge
36c0: 74 2d 61 6c 6c 2d 69 70 73 29 29 0a 20 20 20 20 t-all-ips)).
36d0: 20 20 20 20 3b 3b 28 61 6c 6c 2d 6d 79 2d 61 64 ;;(all-my-ad
36e0: 64 72 65 73 73 65 73 2d 6f 6c 64 20 28 76 65 63 dresses-old (vec
36f0: 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 69 tor->list (hosti
3700: 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 nfo-addresses (h
3710: 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 ostname->hostinf
3720: 6f 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 o (get-host-name
3730: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 29 0a ))))). ).
3740: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 (cond. (
3750: 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 64 (null? all-my-ad
3760: 64 72 65 73 73 65 73 29 0a 20 20 20 20 20 20 28 dresses). (
3770: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 20 get-host-name))
3780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37a0: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 69 ;; no i
37b0: 6e 74 65 72 66 61 63 65 73 3f 0a 20 20 20 20 20 nterfaces?.
37c0: 28 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 61 6c ((eq? (length al
37d0: 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 20 l-my-addresses)
37e0: 31 29 0a 20 20 20 20 20 20 28 63 61 72 20 61 6c 1). (car al
37f0: 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 29 l-my-addresses))
3800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3810: 20 20 20 20 20 20 3b 3b 20 6f 6e 6c 79 20 6f 6e ;; only on
3820: 65 20 74 6f 20 63 68 6f 6f 73 65 20 66 72 6f 6d e to choose from
3830: 2c 20 6a 75 73 74 20 67 6f 20 77 69 74 68 20 69 , just go with i
3840: 74 0a 20 20 20 20 20 0a 20 20 20 20 20 28 65 6c t. . (el
3850: 73 65 0a 20 20 20 20 20 20 28 63 61 72 20 28 73 se. (car (s
3860: 6f 72 74 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 ort all-my-addre
3870: 73 73 65 73 20 69 70 2d 70 72 65 66 2d 6c 65 73 sses ip-pref-les
3880: 73 3f 29 29 29 0a 20 20 20 20 20 3b 3b 20 28 65 s?))). ;; (e
3890: 6c 73 65 20 0a 20 20 20 20 20 3b 3b 20 20 28 69 lse . ;; (i
38a0: 70 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 20 28 p->string (car (
38b0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
38c0: 78 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 x)
38d0: 20 20 20 20 20 20 20 20 3b 3b 20 74 61 6b 65 20 ;; take
38e0: 61 6e 79 20 62 75 74 20 31 32 37 2e 0a 20 20 20 any but 127..
38f0: 20 20 3b 3b 20 20 20 20 09 09 09 20 28 6e 6f 74 ;; ... (not
3900: 20 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 2d (eq? (u8vector-
3910: 72 65 66 20 78 20 30 29 20 31 32 37 29 29 29 0a ref x 0) 127))).
3920: 20 20 20 20 20 3b 3b 20 20 20 20 09 09 20 20 20 ;; ..
3930: 20 20 20 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 all-my-addre
3940: 73 73 65 73 29 29 29 29 0a 0a 20 20 20 20 20 29 sses)))).. )
3950: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 ))..(define (get
3960: 2d 61 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 29 -all-ips-sorted)
3970: 0a 20 20 28 73 6f 72 74 20 28 67 65 74 2d 61 6c . (sort (get-al
3980: 6c 2d 69 70 73 29 20 69 70 2d 70 72 65 66 2d 6c l-ips) ip-pref-l
3990: 65 73 73 3f 29 29 0a 0a 28 64 65 66 69 6e 65 20 ess?))..(define
39a0: 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 0a 20 20 (get-all-ips).
39b0: 28 6d 61 70 20 69 70 2d 3e 73 74 72 69 6e 67 20 (map ip->string
39c0: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 0a 09 (vector->list ..
39d0: 09 20 20 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 . (hostinfo-ad
39e0: 64 72 65 73 73 65 73 0a 09 09 20 20 20 20 28 68 dresses... (h
39f0: 6f 73 74 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 ost-information
3a00: 28 63 75 72 72 65 6e 74 2d 68 6f 73 74 6e 61 6d (current-hostnam
3a10: 65 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 e))))))..(define
3a20: 20 28 75 64 61 74 2d 6d 79 2d 68 6f 73 74 2d 70 (udat-my-host-p
3a30: 6f 72 74 20 75 64 61 74 61 29 0a 20 20 28 69 66 ort udata). (if
3a40: 20 28 61 6e 64 20 28 75 64 61 74 2d 6d 79 2d 61 (and (udat-my-a
3a50: 64 64 72 65 73 73 20 75 64 61 74 61 29 28 75 64 ddress udata)(ud
3a60: 61 74 2d 6d 79 2d 70 6f 72 74 20 75 64 61 74 61 at-my-port udata
3a70: 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 28 )). (conc (
3a80: 75 64 61 74 2d 6d 79 2d 61 64 64 72 65 73 73 20 udat-my-address
3a90: 75 64 61 74 61 29 20 22 3a 22 20 28 75 64 61 74 udata) ":" (udat
3aa0: 2d 6d 79 2d 70 6f 72 74 20 75 64 61 74 61 29 29 -my-port udata))
3ab0: 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 28 64 65 . #f))..(de
3ac0: 66 69 6e 65 20 28 75 64 61 74 2d 63 61 70 74 61 fine (udat-capta
3ad0: 69 6e 2d 68 6f 73 74 2d 70 6f 72 74 20 75 64 61 in-host-port uda
3ae0: 74 61 29 0a 20 20 28 69 66 20 28 61 6e 64 20 28 ta). (if (and (
3af0: 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 61 64 64 udat-captain-add
3b00: 72 65 73 73 20 75 64 61 74 61 29 28 75 64 61 74 ress udata)(udat
3b10: 2d 63 61 70 74 61 69 6e 2d 70 6f 72 74 20 75 64 -captain-port ud
3b20: 61 74 61 29 29 0a 20 20 20 20 20 20 28 63 6f 6e ata)). (con
3b30: 63 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d c (udat-captain-
3b40: 61 64 64 72 65 73 73 20 75 64 61 74 61 29 20 22 address udata) "
3b50: 3a 22 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e :" (udat-captain
3b60: 2d 70 6f 72 74 20 75 64 61 74 61 29 29 0a 20 20 -port udata)).
3b70: 20 20 20 20 23 66 29 29 0a 0a 28 64 65 66 69 6e #f))..(defin
3b80: 65 20 28 75 64 61 74 2d 67 65 74 2d 70 65 65 72 e (udat-get-peer
3b90: 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 udata host-port
3ba0: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
3bb0: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 75 64 61 ref/default (uda
3bc0: 74 2d 70 65 65 72 73 20 75 64 61 74 61 29 20 68 t-peers udata) h
3bd0: 6f 73 74 2d 70 6f 72 74 20 23 66 29 29 0a 0a 3b ost-port #f))..;
3be0: 3b 20 73 74 72 75 63 74 20 66 6f 72 20 6b 65 65 ; struct for kee
3bf0: 70 69 6e 67 20 74 72 61 63 6b 20 6f 66 20 6f 74 ping track of ot
3c00: 68 65 72 73 20 77 65 20 61 72 65 20 74 61 6c 6b hers we are talk
3c10: 69 6e 67 20 74 6f 0a 0a 28 64 65 66 73 74 72 75 ing to..(defstru
3c20: 63 74 20 70 65 65 72 0a 20 20 28 61 64 64 72 2d ct peer. (addr-
3c30: 70 6f 72 74 20 20 20 20 20 20 20 23 66 29 0a 20 port #f).
3c40: 20 28 68 6f 73 74 6e 61 6d 65 20 20 20 20 20 20 (hostname
3c50: 20 20 23 66 29 0a 20 20 28 70 69 64 20 20 20 20 #f). (pid
3c60: 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 3b #f). ;
3c70: 3b 20 28 69 6e 70 20 20 20 20 20 20 20 20 20 20 ; (inp
3c80: 20 20 20 23 66 29 0a 20 20 3b 3b 20 28 6f 75 70 #f). ;; (oup
3c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
3ca0: 0a 20 20 28 64 62 73 20 20 20 20 20 20 20 20 20 . (dbs
3cb0: 20 20 20 27 28 29 29 20 3b 3b 20 6c 69 73 74 20 '()) ;; list
3cc0: 6f 66 20 64 61 74 61 62 61 73 65 73 20 74 68 69 of databases thi
3cd0: 73 20 70 65 65 72 20 69 73 20 63 75 72 72 65 6e s peer is curren
3ce0: 74 6c 79 20 68 61 6e 64 6c 69 6e 67 0a 20 20 29 tly handling. )
3cf0: 0a 0a 28 64 65 66 73 74 72 75 63 74 20 77 6f 72 ..(defstruct wor
3d00: 6b 0a 20 20 28 70 65 65 72 2d 64 61 74 20 20 20 k. (peer-dat
3d10: 23 66 29 0a 20 20 28 68 61 6e 64 6c 65 72 6b 65 #f). (handlerke
3d20: 79 20 23 66 29 0a 20 20 28 71 72 79 6b 65 79 20 y #f). (qrykey
3d30: 20 20 20 20 23 66 29 0a 20 20 28 64 61 74 61 20 #f). (data
3d40: 20 20 20 20 20 20 23 66 29 0a 20 20 28 73 74 61 #f). (sta
3d50: 72 74 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 rt (current
3d60: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 -milliseconds)))
3d70: 0a 0a 23 3b 28 64 65 66 73 74 72 75 63 74 20 64 ..#;(defstruct d
3d80: 62 6f 77 6e 65 72 0a 20 20 28 70 64 61 74 20 20 bowner. (pdat
3d90: 20 20 20 20 20 20 23 66 29 0a 20 20 28 6c 61 73 #f). (las
3da0: 74 2d 75 70 64 61 74 65 20 28 63 75 72 72 65 6e t-update (curren
3db0: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 0a 3b 3b t-seconds)))..;;
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e00: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 61 70 74 61 69 ======.;; Captai
3e10: 6e 20 66 75 6e 63 74 69 6f 6e 73 0a 3b 3b 3d 3d n functions.;;==
3e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e60: 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 42 2f 2f 20 54 68 ====..;; NB// Th
3e70: 69 73 20 6e 65 65 64 73 20 74 6f 20 62 65 20 73 is needs to be s
3e80: 74 61 72 74 65 64 20 69 6e 20 61 20 74 68 72 65 tarted in a thre
3e90: 61 64 0a 3b 3b 0a 3b 3b 20 73 65 74 75 70 20 74 ad.;;.;; setup t
3ea0: 6f 20 62 65 20 61 20 63 61 70 74 61 69 6e 0a 3b o be a captain.;
3eb0: 3b 20 20 20 2d 20 6c 6f 63 61 6c 20 73 65 72 76 ; - local serv
3ec0: 65 72 20 4d 55 53 54 20 62 65 20 73 74 61 72 74 er MUST be start
3ed0: 65 64 20 61 6c 72 65 61 64 79 0a 3b 3b 20 20 20 ed already.;;
3ee0: 2d 20 63 72 65 61 74 65 20 70 6b 74 0a 3b 3b 20 - create pkt.;;
3ef0: 20 20 2d 20 73 74 61 72 74 20 73 65 72 76 65 72 - start server
3f00: 20 70 6f 72 74 20 68 61 6e 64 6c 65 72 0a 3b 3b port handler.;;
3f10: 0a 28 64 65 66 69 6e 65 20 28 73 65 74 75 70 2d .(define (setup-
3f20: 61 73 2d 63 61 70 74 61 69 6e 20 75 64 61 74 61 as-captain udata
3f30: 29 0a 20 20 28 69 66 20 28 63 72 65 61 74 65 2d ). (if (create-
3f40: 63 61 70 74 61 69 6e 2d 70 6b 74 20 75 64 61 74 captain-pkt udat
3f50: 61 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 a). (let* (
3f60: 28 6d 79 2d 61 64 64 72 20 28 75 64 61 74 2d 6d (my-addr (udat-m
3f70: 79 2d 61 64 64 72 65 73 73 20 75 64 61 74 61 29 y-address udata)
3f80: 29 0a 09 20 20 20 20 20 28 6d 79 2d 70 6f 72 74 ).. (my-port
3f90: 20 28 75 64 61 74 2d 6d 79 2d 70 6f 72 74 20 20 (udat-my-port
3fa0: 20 20 75 64 61 74 61 29 29 0a 09 20 20 20 20 20 udata))..
3fb0: 28 74 68 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 (th (make-thread
3fc0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 (lambda ().....
3fd0: 28 75 6c 65 78 2d 68 61 6e 64 6c 65 72 2d 6c 6f (ulex-handler-lo
3fe0: 6f 70 20 75 64 61 74 61 29 29 20 22 43 61 70 74 op udata)) "Capt
3ff0: 61 69 6e 20 68 61 6e 64 6c 65 72 22 29 29 29 0a ain handler"))).
4000: 09 28 75 64 61 74 2d 68 61 6e 64 6c 65 72 2d 74 .(udat-handler-t
4010: 68 72 65 61 64 2d 73 65 74 21 20 75 64 61 74 61 hread-set! udata
4020: 20 74 68 29 0a 09 28 75 64 61 74 2d 63 61 70 74 th)..(udat-capt
4030: 61 69 6e 2d 61 64 64 72 65 73 73 2d 73 65 74 21 ain-address-set!
4040: 20 75 64 61 74 61 20 6d 79 2d 61 64 64 72 29 0a udata my-addr).
4050: 09 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 70 .(udat-captain-p
4060: 6f 72 74 2d 73 65 74 21 20 20 20 20 75 64 61 74 ort-set! udat
4070: 61 20 6d 79 2d 70 6f 72 74 29 0a 09 28 74 68 72 a my-port)..(thr
4080: 65 61 64 2d 73 74 61 72 74 21 20 74 68 29 29 0a ead-start! th)).
4090: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 70 (begin..(p
40a0: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 61 69 rint "ERROR: fai
40b0: 6c 65 64 20 74 6f 20 63 72 65 61 74 65 20 63 61 led to create ca
40c0: 70 74 61 69 6e 20 70 6b 74 22 29 0a 09 23 66 29 ptain pkt")..#f)
40d0: 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 20 70 ))..;; given a p
40e0: 6b 74 73 20 64 69 72 20 72 65 61 64 20 0a 3b 3b kts dir read .;;
40f0: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 61 6c .(define (get-al
4100: 6c 2d 63 61 70 74 61 69 6e 2d 70 6b 74 73 20 75 l-captain-pkts u
4110: 64 61 74 61 29 0a 20 20 28 6c 65 74 2a 20 28 28 data). (let* ((
4120: 70 6b 74 73 64 69 72 20 20 20 20 20 20 20 28 6c pktsdir (l
4130: 65 74 20 28 28 64 20 28 75 64 61 74 2d 63 70 6b et ((d (udat-cpk
4140: 74 73 2d 64 69 72 20 75 64 61 74 61 29 29 29 0a ts-dir udata))).
4150: 09 09 09 20 20 28 69 66 20 28 66 69 6c 65 2d 65 ... (if (file-e
4160: 78 69 73 74 73 3f 20 64 29 0a 09 09 09 20 20 20 xists? d)....
4170: 20 20 20 64 0a 09 09 09 20 20 20 20 20 20 28 62 d.... (b
4180: 65 67 69 6e 0a 09 09 09 09 28 63 72 65 61 74 65 egin.....(create
4190: 2d 64 69 72 65 63 74 6f 72 79 20 64 20 23 74 29 -directory d #t)
41a0: 0a 09 09 09 09 64 29 29 29 29 0a 09 20 28 61 6c .....d)))).. (al
41b0: 6c 2d 70 6b 74 2d 66 69 6c 65 73 20 28 67 6c 6f l-pkt-files (glo
41c0: 62 20 28 63 6f 6e 63 20 70 6b 74 73 64 69 72 20 b (conc pktsdir
41d0: 22 2f 2a 2e 70 6b 74 22 29 29 29 0a 09 20 28 70 "/*.pkt"))).. (p
41e0: 6b 74 2d 73 70 65 63 20 20 20 20 20 20 28 75 64 kt-spec (ud
41f0: 61 74 2d 63 70 6b 74 2d 73 70 65 63 20 75 64 61 at-cpkt-spec uda
4200: 74 61 29 29 29 0a 20 20 20 20 28 6d 61 70 20 28 ta))). (map (
4210: 6c 61 6d 62 64 61 20 28 70 6b 74 2d 66 69 6c 65 lambda (pkt-file
4220: 29 0a 09 20 20 20 28 72 65 61 64 2d 70 6b 74 2d ).. (read-pkt-
4230: 3e 61 6c 69 73 74 20 70 6b 74 2d 66 69 6c 65 20 >alist pkt-file
4240: 70 6b 74 73 70 65 63 3a 20 70 6b 74 2d 73 70 65 pktspec: pkt-spe
4250: 63 29 29 0a 09 20 61 6c 6c 2d 70 6b 74 2d 66 69 c)).. all-pkt-fi
4260: 6c 65 73 29 29 29 0a 0a 3b 3b 20 73 6f 72 74 20 les)))..;; sort
4270: 62 79 20 44 20 74 68 65 6e 20 5a 2c 20 72 65 74 by D then Z, ret
4280: 75 72 6e 20 6f 6e 65 2c 20 63 68 6f 6f 73 65 20 urn one, choose
4290: 74 68 65 20 6f 6c 64 65 73 74 20 74 68 65 6e 0a the oldest then.
42a0: 3b 3b 20 64 69 66 66 65 72 65 6e 74 69 61 74 65 ;; differentiate
42b0: 20 69 66 20 6e 65 65 64 65 64 20 75 73 69 6e 67 if needed using
42c0: 20 74 68 65 20 5a 20 6b 65 79 0a 3b 3b 6c 0a 28 the Z key.;;l.(
42d0: 64 65 66 69 6e 65 20 28 67 65 74 2d 77 69 6e 6e define (get-winn
42e0: 69 6e 67 2d 70 6b 74 20 70 6b 74 73 29 0a 20 20 ing-pkt pkts).
42f0: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 6b 74 73 29 (if (null? pkts)
4300: 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 . #f.
4310: 28 63 61 72 20 28 73 6f 72 74 20 70 6b 74 73 20 (car (sort pkts
4320: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 (lambda (a b)...
4330: 09 28 6c 65 74 20 28 28 61 64 20 28 73 74 72 69 .(let ((ad (stri
4340: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 61 6c 69 73 ng->number (alis
4350: 74 2d 72 65 66 20 27 44 20 61 29 29 29 0a 09 09 t-ref 'D a)))...
4360: 09 20 20 20 20 20 20 28 62 64 20 28 73 74 72 69 . (bd (stri
4370: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 61 6c 69 73 ng->number (alis
4380: 74 2d 72 65 66 20 27 44 20 62 29 29 29 29 0a 09 t-ref 'D b))))..
4390: 09 09 20 20 28 69 66 20 28 65 71 3f 20 61 20 62 .. (if (eq? a b
43a0: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 ).... (let
43b0: 28 28 61 7a 20 28 61 6c 69 73 74 2d 72 65 66 20 ((az (alist-ref
43c0: 27 5a 20 61 29 29 0a 09 09 09 09 20 20 20 20 28 'Z a))..... (
43d0: 62 7a 20 28 61 6c 69 73 74 2d 72 65 66 20 27 5a bz (alist-ref 'Z
43e0: 20 62 29 29 29 0a 09 09 09 09 28 73 74 72 69 6e b))).....(strin
43f0: 67 3e 3d 3f 20 61 7a 20 62 7a 29 29 0a 09 09 09 g>=? az bz))....
4400: 20 20 20 20 20 20 28 3e 20 61 64 20 62 64 29 29 (> ad bd))
4410: 29 29 29 29 29 29 0a 0a 3b 3b 20 70 75 74 20 74 ))))))..;; put t
4420: 68 65 20 68 6f 73 74 2c 20 69 70 2c 20 70 6f 72 he host, ip, por
4430: 74 20 61 6e 64 20 70 69 64 20 69 6e 74 6f 20 61 t and pid into a
4440: 20 70 6b 74 20 69 6e 0a 3b 3b 20 74 68 65 20 63 pkt in.;; the c
4450: 61 70 74 61 69 6e 20 70 6b 74 73 20 64 69 72 0a aptain pkts dir.
4460: 3b 3b 20 20 2d 20 61 73 73 75 6d 65 73 20 75 73 ;; - assumes us
4470: 65 72 20 68 61 73 20 61 6c 72 65 61 64 79 20 66 er has already f
4480: 69 72 65 64 20 75 70 20 61 20 73 65 72 76 65 72 ired up a server
4490: 0a 3b 3b 20 20 20 20 77 68 69 63 68 20 77 69 6c .;; which wil
44a0: 6c 20 62 65 20 69 6e 20 74 68 65 20 75 64 61 74 l be in the udat
44b0: 61 20 73 74 72 75 63 74 0a 3b 3b 0a 28 64 65 66 a struct.;;.(def
44c0: 69 6e 65 20 28 63 72 65 61 74 65 2d 63 61 70 74 ine (create-capt
44d0: 61 69 6e 2d 70 6b 74 20 75 64 61 74 61 29 0a 20 ain-pkt udata).
44e0: 20 28 69 66 20 28 6e 6f 74 20 28 75 64 61 74 2d (if (not (udat-
44f0: 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 75 64 serv-listener ud
4500: 61 74 61 29 29 0a 20 20 20 20 20 20 28 62 65 67 ata)). (beg
4510: 69 6e 0a 09 28 70 72 69 6e 74 20 22 45 52 52 4f in..(print "ERRO
4520: 52 3a 20 63 72 65 61 74 65 2d 63 61 70 74 61 69 R: create-captai
4530: 6e 2d 70 6b 74 20 63 61 6c 6c 65 64 20 77 69 74 n-pkt called wit
4540: 68 20 6f 75 74 20 61 20 6c 69 73 74 65 6e 65 72 h out a listener
4550: 22 29 0a 09 23 66 29 0a 20 20 20 20 20 20 28 6c ")..#f). (l
4560: 65 74 2a 20 28 28 70 6b 74 64 61 74 20 60 28 28 et* ((pktdat `((
4570: 70 6f 72 74 20 20 20 2e 20 2c 28 75 64 61 74 2d port . ,(udat-
4580: 6d 79 2d 70 6f 72 74 20 75 64 61 74 61 29 29 0a my-port udata)).
4590: 09 09 20 20 20 20 20 20 20 28 68 6f 73 74 20 20 .. (host
45a0: 20 2e 20 2c 28 75 64 61 74 2d 6d 79 2d 68 6f 73 . ,(udat-my-hos
45b0: 74 6e 61 6d 65 20 75 64 61 74 61 29 29 0a 09 09 tname udata))...
45c0: 20 20 20 20 20 20 20 28 69 70 61 64 64 72 20 2e (ipaddr .
45d0: 20 2c 28 75 64 61 74 2d 6d 79 2d 61 64 64 72 65 ,(udat-my-addre
45e0: 73 73 20 75 64 61 74 61 29 29 0a 09 09 20 20 20 ss udata))...
45f0: 20 20 20 20 28 70 69 64 20 20 20 20 2e 20 2c 28 (pid . ,(
4600: 75 64 61 74 2d 6d 79 2d 70 69 64 20 20 20 20 20 udat-my-pid
4610: 75 64 61 74 61 29 29 29 29 0a 09 20 20 20 20 20 udata))))..
4620: 28 70 6b 74 64 69 72 20 20 28 75 64 61 74 2d 63 (pktdir (udat-c
4630: 70 6b 74 73 2d 64 69 72 20 75 64 61 74 61 29 29 pkts-dir udata))
4640: 0a 09 20 20 20 20 20 28 70 6b 74 73 70 65 63 20 .. (pktspec
4650: 28 75 64 61 74 2d 63 70 6b 74 2d 73 70 65 63 20 (udat-cpkt-spec
4660: 75 64 61 74 61 29 29 0a 09 20 20 20 20 20 29 0a udata)).. ).
4670: 09 28 75 64 61 74 2d 6d 79 2d 63 70 6b 74 2d 6b .(udat-my-cpkt-k
4680: 65 79 2d 73 65 74 21 0a 09 20 75 64 61 74 61 0a ey-set!.. udata.
4690: 09 20 28 77 72 69 74 65 2d 61 6c 69 73 74 2d 3e . (write-alist->
46a0: 70 6b 74 0a 09 20 20 70 6b 74 64 69 72 0a 09 20 pkt.. pktdir..
46b0: 20 70 6b 74 64 61 74 0a 09 20 20 70 6b 74 73 70 pktdat.. pktsp
46c0: 65 63 3a 20 70 6b 74 73 70 65 63 0a 09 20 20 70 ec: pktspec.. p
46d0: 74 79 70 65 3a 20 20 20 27 63 61 70 74 61 69 6e type: 'captain
46e0: 29 29 0a 09 28 75 64 61 74 2d 6d 79 2d 63 70 6b ))..(udat-my-cpk
46f0: 74 2d 6b 65 79 20 75 64 61 74 61 29 29 29 29 0a t-key udata)))).
4700: 0a 3b 3b 20 72 65 6d 6f 76 65 20 70 6b 74 20 61 .;; remove pkt a
4710: 73 73 6f 63 69 61 74 65 64 20 77 69 74 68 20 63 ssociated with c
4720: 61 70 74 6e 20 28 74 68 65 20 5a 20 6b 65 79 20 aptn (the Z key
4730: 2e 70 6b 74 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 .pkt).;;.(define
4740: 20 28 72 65 6d 6f 76 65 2d 63 61 70 74 61 69 6e (remove-captain
4750: 2d 70 6b 74 20 75 64 61 74 61 20 63 61 70 74 6e -pkt udata captn
4760: 29 0a 20 20 28 6c 65 74 20 28 28 5a 20 20 20 20 ). (let ((Z
4770: 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 5a (alist-ref 'Z
4780: 20 63 61 70 74 6e 29 29 0a 09 28 63 70 6b 74 64 captn))..(cpktd
4790: 69 72 20 28 75 64 61 74 2d 63 70 6b 74 73 2d 64 ir (udat-cpkts-d
47a0: 69 72 20 75 64 61 74 61 29 29 29 0a 20 20 20 20 ir udata))).
47b0: 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 28 63 (delete-file* (c
47c0: 6f 6e 63 20 63 70 6b 74 64 69 72 20 22 2f 22 20 onc cpktdir "/"
47d0: 5a 20 22 2e 70 6b 74 22 29 29 29 29 0a 0a 3b 3b Z ".pkt"))))..;;
47e0: 20 63 61 6c 6c 20 61 6c 6c 20 6b 6e 6f 77 6e 20 call all known
47f0: 70 65 65 72 73 20 61 6e 64 20 74 65 6c 6c 20 74 peers and tell t
4800: 68 65 6d 20 74 6f 20 64 65 6c 65 74 65 20 74 68 hem to delete th
4810: 65 69 72 20 69 6e 66 6f 20 6f 6e 20 74 68 65 20 eir info on the
4820: 63 61 70 74 61 69 6e 0a 3b 3b 20 74 68 75 73 20 captain.;; thus
4830: 66 6f 72 63 69 6e 67 20 74 68 65 6d 20 74 6f 20 forcing them to
4840: 72 65 2d 72 65 61 64 20 70 6b 74 73 20 61 6e 64 re-read pkts and
4850: 20 63 6f 6e 6e 65 63 74 20 74 6f 20 61 20 6e 65 connect to a ne
4860: 77 20 63 61 70 74 61 69 6e 0a 3b 3b 20 63 61 6c w captain.;; cal
4870: 6c 20 74 68 69 73 20 77 68 65 6e 20 74 68 65 20 l this when the
4880: 63 61 70 74 61 69 6e 20 6e 65 65 64 73 20 74 6f captain needs to
4890: 20 65 78 69 74 20 61 6e 64 20 69 66 20 61 6e 20 exit and if an
48a0: 6f 6c 64 65 72 20 63 61 70 74 61 69 6e 20 69 73 older captain is
48b0: 0a 3b 3b 20 64 65 74 65 63 74 65 64 2e 20 44 75 .;; detected. Du
48c0: 65 20 74 6f 20 64 65 6c 61 79 73 20 69 6e 20 73 e to delays in s
48d0: 65 6e 64 69 6e 67 20 66 69 6c 65 20 6d 65 74 61 ending file meta
48e0: 20 64 61 74 61 20 69 6e 20 4e 46 53 20 6d 75 6c data in NFS mul
48f0: 74 69 70 6c 65 0a 3b 3b 20 63 61 70 74 61 69 6e tiple.;; captain
4900: 73 20 63 61 6e 20 62 65 20 69 6e 69 74 69 61 74 s can be initiat
4910: 65 64 20 69 6e 20 61 20 22 53 74 6f 72 6d 20 6f ed in a "Storm o
4920: 66 20 43 61 70 74 61 69 6e 73 22 2c 20 62 6f 6f f Captains", boo
4930: 6b 20 73 6f 6f 6e 20 74 6f 20 62 65 0a 3b 3b 20 k soon to be.;;
4940: 6f 6e 20 41 6d 61 7a 6f 6e 0a 3b 3b 0a 28 64 65 on Amazon.;;.(de
4950: 66 69 6e 65 20 28 64 72 6f 70 2d 63 61 70 74 61 fine (drop-capta
4960: 69 6e 20 75 64 61 74 61 29 0a 20 20 28 6c 65 74 in udata). (let
4970: 2a 20 28 28 70 65 65 72 73 20 28 68 61 73 68 2d * ((peers (hash-
4980: 74 61 62 6c 65 2d 6b 65 79 73 20 28 75 64 61 74 table-keys (udat
4990: 2d 70 65 65 72 73 20 75 64 61 74 61 29 29 29 0a -peers udata))).
49a0: 09 20 28 63 6f 6f 6b 69 65 20 28 6d 61 6b 65 2d . (cookie (make-
49b0: 63 6f 6f 6b 69 65 20 75 64 61 74 61 29 29 29 0a cookie udata))).
49c0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
49d0: 20 20 20 28 6c 61 6d 62 64 61 20 28 68 6f 73 74 (lambda (host
49e0: 2d 70 6f 72 74 29 0a 20 20 20 20 20 20 20 28 73 -port). (s
49f0: 65 6e 64 20 75 64 61 74 61 20 68 6f 73 74 2d 70 end udata host-p
4a00: 6f 72 74 20 27 64 72 6f 70 63 61 70 74 61 69 6e ort 'dropcaptain
4a10: 20 63 6f 6f 6b 69 65 20 22 6e 6f 6d 73 67 22 20 cookie "nomsg"
4a20: 72 65 74 76 61 6c 3a 20 23 74 29 29 0a 20 20 20 retval: #t)).
4a30: 20 20 70 65 65 72 73 29 29 29 0a 0a 3b 3b 3d 3d peers)))..;;==
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a80: 3d 3d 3d 3d 0a 3b 3b 20 73 65 72 76 65 72 20 70 ====.;; server p
4a90: 72 69 6d 69 74 69 76 65 73 0a 3b 3b 3d 3d 3d 3d rimitives.;;====
4aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ae0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ==..(define (mak
4af0: 65 2d 63 6f 6f 6b 69 65 20 75 64 61 74 61 29 0a e-cookie udata).
4b00: 20 20 28 6c 65 74 20 28 28 6e 65 77 63 6e 75 6d (let ((newcnum
4b10: 20 28 2b 20 28 75 64 61 74 2d 63 6e 75 6d 20 75 (+ (udat-cnum u
4b20: 64 61 74 61 29 20 31 29 29 29 0a 20 20 20 20 28 data) 1))). (
4b30: 75 64 61 74 2d 63 6e 75 6d 2d 73 65 74 21 20 75 udat-cnum-set! u
4b40: 64 61 74 61 20 6e 65 77 63 6e 75 6d 29 0a 20 20 data newcnum).
4b50: 20 20 28 63 6f 6e 63 20 28 75 64 61 74 2d 6d 79 (conc (udat-my
4b60: 2d 61 64 64 72 65 73 73 20 75 64 61 74 61 29 20 -address udata)
4b70: 22 3a 22 0a 09 20 20 28 75 64 61 74 2d 6d 79 2d ":".. (udat-my-
4b80: 70 6f 72 74 20 20 20 20 75 64 61 74 61 29 20 22 port udata) "
4b90: 2d 22 0a 09 20 20 28 75 64 61 74 2d 6d 79 2d 70 -".. (udat-my-p
4ba0: 69 64 20 20 20 20 20 75 64 61 74 61 29 20 22 2d id udata) "-
4bb0: 22 0a 09 20 20 6e 65 77 63 6e 75 6d 29 29 29 0a ".. newcnum))).
4bc0: 0a 3b 3b 20 63 72 65 61 74 65 20 61 20 74 63 70 .;; create a tcp
4bd0: 20 6c 69 73 74 65 6e 65 72 20 61 6e 64 20 72 65 listener and re
4be0: 74 75 72 6e 20 61 20 70 6f 70 75 6c 61 74 65 64 turn a populated
4bf0: 20 75 64 61 74 20 73 74 72 75 63 74 20 77 69 74 udat struct wit
4c00: 68 0a 3b 3b 20 6d 79 20 70 6f 72 74 2c 20 61 64 h.;; my port, ad
4c10: 64 72 65 73 73 2c 20 68 6f 73 74 6e 61 6d 65 2c dress, hostname,
4c20: 20 70 69 64 20 65 74 63 2e 0a 3b 3b 20 72 65 74 pid etc..;; ret
4c30: 75 72 6e 20 23 66 20 69 66 20 66 61 69 6c 20 74 urn #f if fail t
4c40: 6f 20 66 69 6e 64 20 61 20 70 6f 72 74 20 74 6f o find a port to
4c50: 20 61 6c 6c 6f 63 61 74 65 2e 0a 3b 3b 0a 3b 3b allocate..;;.;;
4c60: 20 20 69 66 20 75 64 61 74 61 2d 69 6e 20 69 73 if udata-in is
4c70: 20 23 66 20 63 72 65 61 74 65 20 74 68 65 20 72 #f create the r
4c80: 65 63 6f 72 64 0a 3b 3b 20 20 69 66 20 74 68 65 ecord.;; if the
4c90: 72 65 20 69 73 20 61 6c 72 65 61 64 79 20 61 20 re is already a
4ca0: 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 72 65 serv-listener re
4cb0: 74 75 72 6e 20 74 68 65 20 75 64 61 74 61 0a 3b turn the udata.;
4cc0: 3b 0a 28 64 65 66 69 6e 65 20 28 73 74 61 72 74 ;.(define (start
4cd0: 2d 73 65 72 76 65 72 2d 66 69 6e 64 2d 70 6f 72 -server-find-por
4ce0: 74 20 75 64 61 74 61 2d 69 6e 20 23 21 6f 70 74 t udata-in #!opt
4cf0: 69 6f 6e 61 6c 20 28 70 6f 72 74 20 34 32 34 32 ional (port 4242
4d00: 29 28 74 72 69 65 73 20 30 29 29 0a 20 20 28 6c )(tries 0)). (l
4d10: 65 74 20 28 28 75 64 61 74 61 20 28 6f 72 20 75 et ((udata (or u
4d20: 64 61 74 61 2d 69 6e 20 28 6d 61 6b 65 2d 75 64 data-in (make-ud
4d30: 61 74 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 at)))). (if (
4d40: 75 64 61 74 2d 73 65 72 76 2d 6c 69 73 74 65 6e udat-serv-listen
4d50: 65 72 20 75 64 61 74 61 29 20 3b 3b 20 54 4f 44 er udata) ;; TOD
4d60: 4f 20 2d 20 61 64 64 20 63 68 65 63 6b 20 74 68 O - add check th
4d70: 61 74 20 74 68 65 20 6c 69 73 74 65 6e 65 72 20 at the listener
4d80: 69 73 20 61 6c 69 76 65 20 61 6e 64 20 72 65 61 is alive and rea
4d90: 64 79 3f 0a 09 75 64 61 74 61 0a 09 28 6c 65 74 dy?..udata..(let
4da0: 20 28 28 72 65 73 20 28 63 6f 6e 6e 65 63 74 2d ((res (connect-
4db0: 73 65 72 76 65 72 20 75 64 61 74 61 20 70 6f 72 server udata por
4dc0: 74 29 29 29 0a 09 20 20 28 69 66 20 72 65 73 0a t))).. (if res.
4dd0: 09 20 20 20 20 20 20 72 65 73 0a 09 20 20 20 20 . res..
4de0: 20 20 28 62 65 67 69 6e 0a 09 09 3b 3b 20 28 70 (begin...;; (p
4df0: 72 69 6e 74 20 22 43 6f 75 6c 64 20 6e 6f 74 20 rint "Could not
4e00: 63 6f 6e 6e 65 63 74 20 74 6f 20 22 20 70 6f 72 connect to " por
4e10: 74 29 0a 09 09 28 69 66 20 28 61 6e 64 20 28 3c t)...(if (and (<
4e20: 20 70 6f 72 74 20 20 36 35 35 33 35 29 0a 09 09 port 65535)...
4e30: 09 20 28 3c 20 74 72 69 65 73 20 31 30 30 30 30 . (< tries 10000
4e40: 29 29 20 3b 3b 20 6d 61 6b 65 20 74 68 69 73 20 )) ;; make this
4e50: 6e 75 6d 62 65 72 20 62 69 67 67 65 72 20 77 68 number bigger wh
4e60: 65 6e 20 74 68 69 6e 67 73 20 61 72 65 20 77 6f en things are wo
4e70: 72 6b 69 6e 67 0a 09 09 20 20 20 20 28 73 74 61 rking... (sta
4e80: 72 74 2d 73 65 72 76 65 72 2d 66 69 6e 64 2d 70 rt-server-find-p
4e90: 6f 72 74 20 75 64 61 74 61 20 28 2b 20 70 6f 72 ort udata (+ por
4ea0: 74 20 31 29 28 2b 20 74 72 69 65 73 20 31 29 29 t 1)(+ tries 1))
4eb0: 0a 09 09 20 20 20 20 23 66 29 29 29 29 29 29 29 ... #f)))))))
4ec0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 6e 65 ..(define (conne
4ed0: 63 74 2d 73 65 72 76 65 72 20 75 64 61 74 61 20 ct-server udata
4ee0: 70 6f 72 74 29 0a 20 20 3b 3b 20 28 74 63 70 2d port). ;; (tcp-
4ef0: 6c 69 73 74 65 6e 65 72 2d 73 6f 63 6b 65 74 20 listener-socket
4f00: 4c 49 53 54 45 4e 45 52 29 28 73 6f 63 6b 65 74 LISTENER)(socket
4f10: 2d 6e 61 6d 65 20 73 6f 29 0a 20 20 3b 3b 20 73 -name so). ;; s
4f20: 6f 63 6b 61 64 64 72 2d 61 64 64 72 65 73 73 2c ockaddr-address,
4f30: 20 73 6f 63 6b 61 64 64 72 2d 70 6f 72 74 2c 20 sockaddr-port,
4f40: 73 6f 63 6b 61 64 64 72 2d 3e 73 74 72 69 6e 67 sockaddr->string
4f50: 0a 20 20 28 6c 65 74 2a 20 28 28 74 6c 73 6e 20 . (let* ((tlsn
4f60: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
4f70: 6e 73 0a 09 09 20 20 20 65 78 6e 0a 09 09 20 20 ns... exn...
4f80: 20 23 66 20 3b 3b 20 4e 42 2f 2f 20 4e 45 45 44 #f ;; NB// NEED
4f90: 20 42 45 54 54 45 52 20 48 41 4e 44 4c 49 4e 47 BETTER HANDLING
4fa0: 20 48 45 52 45 20 41 53 41 50 0a 09 09 20 28 74 HERE ASAP... (t
4fb0: 63 70 2d 6c 69 73 74 65 6e 20 70 6f 72 74 20 31 cp-listen port 1
4fc0: 30 30 30 20 23 66 29 29 29 20 3b 3b 20 28 74 63 000 #f))) ;; (tc
4fd0: 70 2d 6c 69 73 74 65 6e 20 54 43 50 50 4f 52 54 p-listen TCPPORT
4fe0: 20 5b 42 41 43 4b 4c 4f 47 20 5b 48 4f 53 54 5d [BACKLOG [HOST]
4ff0: 5d 29 0a 09 20 28 61 64 64 72 20 28 67 65 74 2d ]).. (addr (get-
5000: 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 73 73 29 my-best-address)
5010: 29 29 20 3b 3b 20 28 68 6f 73 74 69 6e 66 6f 2d )) ;; (hostinfo-
5020: 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 74 2d addresses (host-
5030: 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 63 75 72 information (cur
5040: 72 65 6e 74 2d 68 6f 73 74 6e 61 6d 65 29 29 29 rent-hostname)))
5050: 0a 20 20 20 20 28 69 66 20 74 6c 73 6e 0a 09 28 . (if tlsn..(
5060: 62 65 67 69 6e 0a 09 20 20 28 75 64 61 74 2d 6d begin.. (udat-m
5070: 79 2d 61 64 64 72 65 73 73 2d 73 65 74 21 20 20 y-address-set!
5080: 20 20 75 64 61 74 61 20 61 64 64 72 29 0a 09 20 udata addr)..
5090: 20 28 75 64 61 74 2d 6d 79 2d 70 6f 72 74 2d 73 (udat-my-port-s
50a0: 65 74 21 20 20 20 20 20 20 20 75 64 61 74 61 20 et! udata
50b0: 70 6f 72 74 29 0a 09 20 20 28 75 64 61 74 2d 6d port).. (udat-m
50c0: 79 2d 68 6f 73 74 6e 61 6d 65 2d 73 65 74 21 20 y-hostname-set!
50d0: 20 20 75 64 61 74 61 20 28 67 65 74 2d 68 6f 73 udata (get-hos
50e0: 74 2d 6e 61 6d 65 29 29 0a 09 20 20 28 75 64 61 t-name)).. (uda
50f0: 74 2d 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 2d t-serv-listener-
5100: 73 65 74 21 20 75 64 61 74 61 20 74 6c 73 6e 29 set! udata tlsn)
5110: 0a 09 20 20 75 64 61 74 61 29 0a 09 23 66 29 29 .. udata)..#f))
5120: 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d )..(define (get-
5130: 70 65 65 72 2d 64 61 74 20 75 64 61 74 61 20 68 peer-dat udata h
5140: 6f 73 74 2d 70 6f 72 74 20 23 21 6f 70 74 69 6f ost-port #!optio
5150: 6e 61 6c 20 28 68 6f 73 74 6e 61 6d 65 20 23 66 nal (hostname #f
5160: 29 28 70 69 64 20 23 66 29 29 0a 20 20 28 6c 65 )(pid #f)). (le
5170: 74 2a 20 28 28 70 64 61 74 20 28 6f 72 20 28 75 t* ((pdat (or (u
5180: 64 61 74 2d 67 65 74 2d 70 65 65 72 20 75 64 61 dat-get-peer uda
5190: 74 61 20 68 6f 73 74 2d 70 6f 72 74 29 0a 09 09 ta host-port)...
51a0: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
51b0: 74 69 6f 6e 73 20 3b 3b 20 45 52 52 4f 52 20 2d tions ;; ERROR -
51c0: 20 4d 41 4b 45 20 54 48 49 53 20 45 58 43 45 50 MAKE THIS EXCEP
51d0: 54 49 4f 4e 20 48 41 4e 44 4c 45 52 20 4d 4f 52 TION HANDLER MOR
51e0: 45 20 53 50 45 43 49 46 49 43 0a 09 09 20 20 20 E SPECIFIC...
51f0: 20 65 78 6e 0a 09 09 20 20 20 20 23 66 0a 09 09 exn... #f...
5200: 20 20 20 20 28 6c 65 74 20 28 28 6e 70 64 61 74 (let ((npdat
5210: 20 28 6d 61 6b 65 2d 70 65 65 72 20 61 64 64 72 (make-peer addr
5220: 2d 70 6f 72 74 3a 20 68 6f 73 74 2d 70 6f 72 74 -port: host-port
5230: 29 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 )))... (if
5240: 68 6f 73 74 6e 61 6d 65 20 28 70 65 65 72 2d 68 hostname (peer-h
5250: 6f 73 74 6e 61 6d 65 2d 73 65 74 21 20 6e 70 64 ostname-set! npd
5260: 61 74 20 68 6f 73 74 6e 61 6d 65 29 29 0a 09 09 at hostname))...
5270: 20 20 20 20 20 20 28 69 66 20 70 69 64 20 28 70 (if pid (p
5280: 65 65 72 2d 70 69 64 2d 73 65 74 21 20 6e 70 64 eer-pid-set! npd
5290: 61 74 20 70 69 64 29 29 0a 09 09 20 20 20 20 20 at pid))...
52a0: 20 6e 70 64 61 74 29 29 29 29 29 0a 20 20 20 20 npdat))))).
52b0: 70 64 61 74 29 29 0a 0a 3b 3b 20 73 65 6e 64 20 pdat))..;; send
52c0: 73 74 72 75 63 74 75 72 65 64 20 64 61 74 61 20 structured data
52d0: 74 6f 20 72 65 63 69 70 69 65 6e 74 0a 3b 3b 0a to recipient.;;.
52e0: 3b 3b 20 20 4e 4f 54 45 3a 20 71 72 79 6b 65 79 ;; NOTE: qrykey
52f0: 20 69 73 20 77 68 61 74 20 77 61 73 20 63 61 6c is what was cal
5300: 6c 65 64 20 74 68 65 20 22 63 6f 6f 6b 69 65 22 led the "cookie"
5310: 20 70 72 65 76 69 6f 75 73 6c 79 0a 3b 3b 0a 3b previously.;;.;
5320: 3b 20 20 20 20 20 72 65 74 76 61 6c 20 74 65 6c ; retval tel
5330: 6c 73 20 73 65 6e 64 20 74 6f 20 65 78 70 65 63 ls send to expec
5340: 74 20 61 6e 64 20 77 61 69 74 20 66 6f 72 20 72 t and wait for r
5350: 65 74 75 72 6e 20 64 61 74 61 20 28 6f 6e 65 20 eturn data (one
5360: 6c 69 6e 65 29 20 61 6e 64 20 72 65 74 75 72 6e line) and return
5370: 20 69 74 20 6f 72 20 74 69 6d 65 20 6f 75 74 0a it or time out.
5380: 3b 3b 20 20 20 20 20 20 20 74 68 69 73 20 69 73 ;; this is
5390: 20 66 6f 72 20 70 69 6e 67 20 77 68 65 72 65 20 for ping where
53a0: 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 6f we don't want to
53b0: 20 6e 65 63 65 73 73 61 72 69 6c 79 20 68 61 76 necessarily hav
53c0: 65 20 73 65 74 20 75 70 20 6f 75 72 20 6f 77 6e e set up our own
53d0: 20 73 65 72 76 65 72 20 79 65 74 2e 0a 3b 3b 0a server yet..;;.
53e0: 28 64 65 66 69 6e 65 20 28 73 65 6e 64 20 75 64 (define (send ud
53f0: 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 20 68 61 ata host-port ha
5400: 6e 64 6c 65 72 20 71 72 79 6b 65 79 20 64 61 74 ndler qrykey dat
5410: 61 0a 09 20 20 20 20 20 20 23 21 6b 65 79 20 28 a.. #!key (
5420: 68 6f 73 74 6e 61 6d 65 20 23 66 29 28 70 69 64 hostname #f)(pid
5430: 20 23 66 29 28 70 61 72 61 6d 73 20 27 28 29 29 #f)(params '())
5440: 28 72 65 74 76 61 6c 20 23 66 29 29 0a 20 20 28 (retval #f)). (
5450: 6c 65 74 2a 20 28 28 6d 79 2d 68 6f 73 74 2d 70 let* ((my-host-p
5460: 6f 72 74 20 28 75 64 61 74 2d 6d 79 2d 68 6f 73 ort (udat-my-hos
5470: 74 2d 70 6f 72 74 20 75 64 61 74 61 29 29 0a 09 t-port udata))..
5480: 20 28 69 73 6d 65 20 20 20 20 20 20 20 20 20 28 (isme (
5490: 65 71 75 61 6c 3f 20 68 6f 73 74 2d 70 6f 72 74 equal? host-port
54a0: 20 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 29 29 20 my-host-port))
54b0: 3b 3b 20 61 6d 20 49 20 63 61 6c 6c 69 6e 67 0a ;; am I calling.
54c0: 09 09 09 09 09 09 09 3b 3b 20 6d 79 73 65 6c 66 .......;; myself
54d0: 3f 0a 09 20 28 64 61 74 20 20 20 20 20 20 20 20 ?.. (dat
54e0: 20 20 28 6c 69 73 74 0a 09 09 09 68 61 6e 64 6c (list....handl
54f0: 65 72 20 20 20 20 20 20 20 20 20 20 20 20 20 20 er
5500: 3b 3b 20 22 20 22 0a 09 09 09 6d 79 2d 68 6f 73 ;; " "....my-hos
5510: 74 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 3b t-port ;
5520: 3b 20 22 20 22 0a 09 09 09 28 75 64 61 74 2d 6d ; " "....(udat-m
5530: 79 2d 70 69 64 20 20 75 64 61 74 61 29 20 3b 3b y-pid udata) ;;
5540: 20 22 20 22 0a 09 09 09 71 72 79 6b 65 79 0a 09 " "....qrykey..
5550: 09 09 70 61 72 61 6d 73 20 3b 3b 28 69 66 20 28 ..params ;;(if (
5560: 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 22 22 null? params) ""
5570: 20 28 63 6f 6e 63 20 22 20 22 0a 09 09 09 20 20 (conc " "....
5580: 20 20 20 20 20 3b 3b 28 73 74 72 69 6e 67 2d 69 ;;(string-i
5590: 6e 74 65 72 73 70 65 72 73 65 20 70 61 72 61 6d ntersperse param
55a0: 73 20 22 20 22 29 29 29 0a 09 09 09 29 29 29 0a s " ")))....))).
55b0: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 73 ;; (print "s
55c0: 65 6e 64 20 69 73 6d 65 20 69 73 20 22 20 28 69 end isme is " (i
55d0: 66 20 69 73 6d 65 20 22 74 72 75 65 21 22 20 22 f isme "true!" "
55e0: 66 61 6c 73 65 21 22 29 20 22 2c 0a 20 20 20 20 false!") ",.
55f0: 3b 3b 20 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 3a ;; my-host-port:
5600: 20 22 20 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 20 " my-host-port
5610: 22 2c 20 68 6f 73 74 2d 70 6f 72 74 3a 20 22 20 ", host-port: "
5620: 68 6f 73 74 2d 70 6f 72 74 29 0a 20 20 20 20 28 host-port). (
5630: 69 66 20 69 73 6d 65 0a 09 28 75 6c 65 78 2d 68 if isme..(ulex-h
5640: 61 6e 64 6c 65 72 20 75 64 61 74 61 20 64 61 74 andler udata dat
5650: 20 64 61 74 61 29 0a 09 28 68 61 6e 64 6c 65 2d data)..(handle-
5660: 65 78 63 65 70 74 69 6f 6e 73 20 3b 3b 20 45 52 exceptions ;; ER
5670: 52 4f 52 20 2d 20 4d 41 4b 45 20 54 48 49 53 20 ROR - MAKE THIS
5680: 45 58 43 45 50 54 49 4f 4e 20 48 41 4e 44 4c 45 EXCEPTION HANDLE
5690: 52 20 4d 4f 52 45 0a 09 09 09 20 20 20 3b 3b 20 R MORE.... ;;
56a0: 53 50 45 43 49 46 49 43 0a 09 20 20 20 20 65 78 SPECIFIC.. ex
56b0: 6e 0a 09 20 20 20 20 23 66 20 0a 09 20 20 28 6c n.. #f .. (l
56c0: 65 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 et-values (((inp
56d0: 20 6f 75 70 29 28 74 63 70 2d 63 6f 6e 6e 65 63 oup)(tcp-connec
56e0: 74 20 68 6f 73 74 2d 70 6f 72 74 29 29 29 0a 09 t host-port)))..
56f0: 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 43 ;;.. ;; C
5700: 4f 4e 54 52 4f 4c 20 4c 49 4e 45 3a 0a 09 20 20 ONTROL LINE:..
5710: 20 20 3b 3b 20 20 20 20 68 61 6e 64 6c 65 72 6b ;; handlerk
5720: 65 79 20 68 6f 73 74 3a 70 6f 72 74 20 70 69 64 ey host:port pid
5730: 20 71 72 79 6b 65 79 20 70 61 72 61 6d 73 20 2e qrykey params .
5740: 2e 2e 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 .... ;;..
5750: 28 6c 65 74 20 28 28 72 65 73 0a 09 09 20 20 20 (let ((res...
5760: 28 69 66 20 28 61 6e 64 20 69 6e 70 20 6f 75 70 (if (and inp oup
5770: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a )... (let*
5780: 20 28 29 0a 09 09 09 20 28 69 66 20 6d 79 2d 68 ().... (if my-h
5790: 6f 73 74 2d 70 6f 72 74 0a 09 09 09 20 20 20 20 ost-port....
57a0: 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 (begin....
57b0: 20 20 28 77 72 69 74 65 20 64 61 74 20 20 6f 75 (write dat ou
57c0: 70 29 0a 09 09 09 20 20 20 20 20 20 20 28 77 72 p).... (wr
57d0: 69 74 65 20 64 61 74 61 20 6f 75 70 29 20 3b 3b ite data oup) ;;
57e0: 20 73 65 6e 64 20 61 73 20 73 65 78 70 72 0a 09 send as sexpr..
57f0: 09 09 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 .. ;; (pri
5800: 6e 74 20 22 53 65 6e 74 20 64 61 74 3a 20 22 20 nt "Sent dat: "
5810: 64 61 74 20 22 20 64 61 74 61 3a 20 22 20 64 61 dat " data: " da
5820: 74 61 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 ta).... (i
5830: 66 20 72 65 74 76 61 6c 0a 09 09 09 09 20 20 20 f retval.....
5840: 28 72 65 61 64 20 69 6e 70 29 0a 09 09 09 09 20 (read inp).....
5850: 20 20 23 74 29 29 0a 09 09 09 20 20 20 20 20 28 #t)).... (
5860: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 begin....
5870: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 73 (print "ERROR: s
5880: 65 6e 64 20 63 61 6c 6c 65 64 20 62 75 74 20 6e end called but n
5890: 6f 20 72 65 63 65 69 76 65 72 20 68 61 73 20 62 o receiver has b
58a0: 65 65 6e 20 73 65 74 75 70 2e 20 50 6c 65 61 73 een setup. Pleas
58b0: 65 20 63 61 6c 6c 20 73 65 74 75 70 20 66 69 72 e call setup fir
58c0: 73 74 21 22 29 0a 09 09 09 20 20 20 20 20 20 20 st!")....
58d0: 23 66 29 29 0a 09 09 09 20 3b 3b 20 4e 4f 54 45 #f)).... ;; NOTE
58e0: 3a 20 44 4f 20 4e 4f 54 20 42 45 20 54 45 4d 50 : DO NOT BE TEMP
58f0: 54 45 44 20 54 4f 20 4c 4f 4f 4b 20 41 54 20 41 TED TO LOOK AT A
5900: 4e 59 20 44 41 54 41 20 4f 4e 20 49 4e 50 20 48 NY DATA ON INP H
5910: 45 52 45 21 0a 09 09 09 20 3b 3b 20 20 20 20 20 ERE!.... ;;
5920: 20 20 28 74 68 65 72 65 20 69 73 20 61 20 6c 69 (there is a li
5930: 73 74 65 6e 65 72 20 66 6f 72 20 68 61 6e 64 6c stener for handl
5940: 69 6e 67 20 74 68 61 74 29 0a 09 09 09 20 29 0a ing that).... ).
5950: 09 09 20 20 20 20 20 20 20 23 66 29 29 29 20 3b .. #f))) ;
5960: 3b 20 23 66 20 6d 65 61 6e 73 20 66 61 69 6c 65 ; #f means faile
5970: 64 20 74 6f 20 63 6f 6e 6e 65 63 74 20 61 6e 64 d to connect and
5980: 20 73 65 6e 64 0a 09 20 20 20 20 20 20 28 63 6c send.. (cl
5990: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 ose-input-port i
59a0: 6e 70 29 0a 09 20 20 20 20 20 20 28 63 6c 6f 73 np).. (clos
59b0: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 e-output-port ou
59c0: 70 29 0a 09 20 20 20 20 20 20 72 65 73 29 29 29 p).. res)))
59d0: 29 29 29 0a 0a 3b 3b 20 73 65 6e 64 20 61 20 72 )))..;; send a r
59e0: 65 71 75 65 73 74 20 74 6f 20 74 68 65 20 67 69 equest to the gi
59f0: 76 65 6e 20 68 6f 73 74 2d 70 6f 72 74 20 61 6e ven host-port an
5a00: 64 20 72 65 67 69 73 74 65 72 20 61 20 6d 61 69 d register a mai
5a10: 6c 62 6f 78 20 69 6e 20 75 64 61 74 61 0a 3b 3b lbox in udata.;;
5a20: 20 77 61 69 74 20 66 6f 72 20 74 68 65 20 6d 61 wait for the ma
5a30: 69 6c 62 6f 78 20 64 61 74 61 20 61 6e 64 20 72 ilbox data and r
5a40: 65 74 75 72 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 eturn it.;;.(def
5a50: 69 6e 65 20 28 73 65 6e 64 2d 72 65 63 65 69 76 ine (send-receiv
5a60: 65 20 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 e udata host-por
5a70: 74 20 68 61 6e 64 6c 65 72 20 71 72 79 6b 65 79 t handler qrykey
5a80: 20 64 61 74 61 20 23 21 6b 65 79 20 28 68 6f 73 data #!key (hos
5a90: 74 6e 61 6d 65 20 23 66 29 28 70 69 64 20 23 66 tname #f)(pid #f
5aa0: 29 28 70 61 72 61 6d 73 20 27 28 29 29 28 74 69 )(params '())(ti
5ab0: 6d 65 6f 75 74 20 32 30 29 29 0a 20 20 28 6c 65 meout 20)). (le
5ac0: 74 20 28 28 6d 62 6f 78 20 20 20 20 20 20 28 6d t ((mbox (m
5ad0: 61 6b 65 2d 6d 61 69 6c 62 6f 78 29 29 0a 09 28 ake-mailbox))..(
5ae0: 6d 62 6f 78 2d 74 69 6d 65 20 28 63 75 72 72 65 mbox-time (curre
5af0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
5b00: 29 0a 09 28 6d 62 6f 78 65 73 20 20 20 20 28 75 )..(mboxes (u
5b10: 64 61 74 2d 6d 62 6f 78 65 73 20 75 64 61 74 61 dat-mboxes udata
5b20: 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 ))). (hash-ta
5b30: 62 6c 65 2d 73 65 74 21 20 6d 62 6f 78 65 73 20 ble-set! mboxes
5b40: 71 72 79 6b 65 79 20 6d 62 6f 78 29 0a 20 20 20 qrykey mbox).
5b50: 20 28 69 66 20 28 73 65 6e 64 20 75 64 61 74 61 (if (send udata
5b60: 20 68 6f 73 74 2d 70 6f 72 74 20 68 61 6e 64 6c host-port handl
5b70: 65 72 20 71 72 79 6b 65 79 20 64 61 74 61 20 68 er qrykey data h
5b80: 6f 73 74 6e 61 6d 65 3a 20 68 6f 73 74 6e 61 6d ostname: hostnam
5b90: 65 20 70 69 64 3a 20 70 69 64 20 70 61 72 61 6d e pid: pid param
5ba0: 73 3a 20 70 61 72 61 6d 73 29 0a 09 28 6c 65 74 s: params)..(let
5bb0: 2a 20 28 28 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 * ((mbox-timeout
5bc0: 2d 73 65 63 73 20 20 20 20 74 69 6d 65 6f 75 74 -secs timeout
5bd0: 29 0a 09 20 20 20 20 20 20 20 28 6d 62 6f 78 2d ).. (mbox-
5be0: 74 69 6d 65 6f 75 74 2d 72 65 73 75 6c 74 20 27 timeout-result '
5bf0: 4d 42 4f 58 5f 54 49 4d 45 4f 55 54 29 0a 09 20 MBOX_TIMEOUT)..
5c00: 20 20 20 20 20 20 28 72 65 73 20 20 20 20 20 20 (res
5c10: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 69 (mai
5c20: 6c 62 6f 78 2d 72 65 63 65 69 76 65 21 20 6d 62 lbox-receive! mb
5c30: 6f 78 20 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d ox mbox-timeout-
5c40: 73 65 63 73 20 6d 62 6f 78 2d 74 69 6d 65 6f 75 secs mbox-timeou
5c50: 74 2d 72 65 73 75 6c 74 29 29 0a 09 20 20 20 20 t-result))..
5c60: 20 20 20 28 6d 62 6f 78 2d 72 65 63 65 69 76 65 (mbox-receive
5c70: 2d 74 69 6d 65 20 20 20 20 28 63 75 72 72 65 6e -time (curren
5c80: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 t-milliseconds))
5c90: 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ).. (hash-table
5ca0: 2d 64 65 6c 65 74 65 21 20 6d 62 6f 78 65 73 20 -delete! mboxes
5cb0: 71 72 79 6b 65 79 29 0a 09 20 20 28 69 66 20 28 qrykey).. (if (
5cc0: 65 71 3f 20 72 65 73 20 27 4d 42 4f 58 5f 54 49 eq? res 'MBOX_TI
5cd0: 4d 45 4f 55 54 29 0a 09 20 20 20 20 20 20 23 66 MEOUT).. #f
5ce0: 0a 09 20 20 20 20 20 20 72 65 73 29 29 0a 09 23 .. res))..#
5cf0: 66 29 29 29 20 3b 3b 20 23 66 20 6d 65 61 6e 73 f))) ;; #f means
5d00: 20 66 61 69 6c 65 64 20 74 6f 20 63 6f 6d 6d 75 failed to commu
5d10: 6e 69 63 61 74 65 0a 0a 3b 3b 20 0a 28 64 65 66 nicate..;; .(def
5d20: 69 6e 65 20 28 75 6c 65 78 2d 68 61 6e 64 6c 65 ine (ulex-handle
5d30: 72 20 75 64 61 74 61 20 63 6f 6e 74 72 6f 6c 64 r udata controld
5d40: 61 74 20 64 61 74 61 29 0a 20 20 28 70 72 69 6e at data). (prin
5d50: 74 20 22 63 6f 6e 74 72 6f 6c 64 61 74 3a 20 22 t "controldat: "
5d60: 20 63 6f 6e 74 72 6f 6c 64 61 74 20 22 20 64 61 controldat " da
5d70: 74 61 3a 20 22 20 64 61 74 61 29 0a 20 20 28 6d ta: " data). (m
5d80: 61 74 63 68 20 63 6f 6e 74 72 6f 6c 64 61 74 20 atch controldat
5d90: 3b 3b 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ;; (string-spli
5da0: 74 20 63 6f 6e 74 72 6f 6c 64 61 74 29 0a 20 20 t controldat).
5db0: 20 20 28 28 68 61 6e 64 6c 65 72 6b 65 79 20 68 ((handlerkey h
5dc0: 6f 73 74 2d 70 6f 72 74 20 70 69 64 20 71 72 79 ost-port pid qry
5dd0: 6b 65 79 20 70 61 72 61 6d 73 20 2e 2e 2e 29 0a key params ...).
5de0: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
5df0: 68 61 6e 64 6c 65 72 6b 65 79 3a 20 22 20 68 61 handlerkey: " ha
5e00: 6e 64 6c 65 72 6b 65 79 20 22 20 68 6f 73 74 2d ndlerkey " host-
5e10: 70 6f 72 74 3a 20 22 20 68 6f 73 74 2d 70 6f 72 port: " host-por
5e20: 74 20 22 20 70 69 64 3a 20 22 20 70 69 64 20 22 t " pid: " pid "
5e30: 20 71 72 79 6b 65 79 3a 20 22 20 71 72 79 6b 65 qrykey: " qryke
5e40: 79 20 22 20 70 61 72 61 6d 73 3a 20 22 20 70 61 y " params: " pa
5e50: 72 61 6d 73 29 0a 20 20 20 20 20 28 63 61 73 65 rams). (case
5e60: 20 68 61 6e 64 6c 65 72 6b 65 79 20 3b 3b 20 28 handlerkey ;; (
5e70: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 68 string->symbol h
5e80: 61 6e 64 6c 65 72 6b 65 79 29 0a 20 20 20 20 20 andlerkey).
5e90: 20 20 28 28 61 63 6b 29 28 70 72 69 6e 74 20 22 ((ack)(print "
5ea0: 47 6f 74 20 61 63 6b 21 22 29 29 0a 20 20 20 20 Got ack!")).
5eb0: 20 20 20 28 28 70 69 6e 67 29 20 3b 3b 20 73 70 ((ping) ;; sp
5ec0: 65 63 69 61 6c 20 63 61 73 65 20 2d 20 72 65 74 ecial case - ret
5ed0: 75 72 6e 20 72 65 73 75 6c 74 20 69 6d 6d 65 64 urn result immed
5ee0: 69 61 74 65 6c 79 20 6f 6e 20 74 68 65 20 73 61 iately on the sa
5ef0: 6d 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 28 me connection..(
5f00: 6c 65 74 2a 20 28 28 70 72 6f 63 20 20 28 68 61 let* ((proc (ha
5f10: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
5f20: 61 75 6c 74 20 28 75 64 61 74 2d 68 61 6e 64 6c ault (udat-handl
5f30: 65 72 73 20 75 64 61 74 61 29 20 27 70 69 6e 67 ers udata) 'ping
5f40: 20 23 66 29 29 0a 09 20 20 20 20 20 20 20 28 76 #f)).. (v
5f50: 61 6c 20 20 20 28 69 66 20 70 72 6f 63 20 28 70 al (if proc (p
5f60: 72 6f 63 29 20 22 67 6f 74 70 69 6e 67 22 29 29 roc) "gotping"))
5f70: 0a 09 20 20 20 20 20 20 20 28 70 65 65 72 20 20 .. (peer
5f80: 28 6d 61 6b 65 2d 70 65 65 72 20 61 64 64 72 2d (make-peer addr-
5f90: 70 6f 72 74 3a 20 68 6f 73 74 2d 70 6f 72 74 20 port: host-port
5fa0: 70 69 64 3a 20 70 69 64 29 29 0a 09 20 20 20 20 pid: pid))..
5fb0: 20 20 20 28 64 62 73 68 61 73 68 20 28 75 64 61 (dbshash (uda
5fc0: 74 2d 64 62 6f 77 6e 65 72 73 20 75 64 61 74 61 t-dbowners udata
5fd0: 29 29 29 0a 09 20 20 28 70 65 65 72 2d 64 62 73 ))).. (peer-dbs
5fe0: 2d 73 65 74 21 20 70 65 65 72 20 70 61 72 61 6d -set! peer param
5ff0: 73 29 20 3b 3b 20 70 61 72 61 6d 73 20 66 6f 72 s) ;; params for
6000: 20 70 69 6e 67 20 69 73 20 6c 69 73 74 20 6f 66 ping is list of
6010: 20 64 62 73 20 6f 77 6e 65 64 20 62 79 20 70 69 dbs owned by pi
6020: 6e 67 65 72 0a 09 20 20 28 66 6f 72 2d 65 61 63 nger.. (for-eac
6030: 68 20 28 6c 61 6d 62 64 61 20 28 64 62 66 69 6c h (lambda (dbfil
6040: 65 29 0a 09 09 20 20 20 20 20 20 28 68 61 73 68 e)... (hash
6050: 2d 74 61 62 6c 65 2d 73 65 74 21 20 64 62 73 68 -table-set! dbsh
6060: 61 73 68 20 64 62 66 69 6c 65 20 68 6f 73 74 2d ash dbfile host-
6070: 70 6f 72 74 29 29 20 3b 3b 20 57 52 4f 4e 47 3f port)) ;; WRONG?
6080: 0a 09 09 20 20 20 20 70 61 72 61 6d 73 29 20 3b ... params) ;
6090: 3b 20 72 65 67 69 73 74 65 72 20 65 61 63 68 20 ; register each
60a0: 64 62 20 69 6e 20 74 68 65 20 64 62 73 68 61 73 db in the dbshas
60b0: 68 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 68 h.. (if (not (h
60c0: 61 73 68 2d 74 61 62 6c 65 2d 65 78 69 73 74 73 ash-table-exists
60d0: 3f 20 28 75 64 61 74 2d 70 65 65 72 73 20 75 64 ? (udat-peers ud
60e0: 61 74 61 29 20 68 6f 73 74 2d 70 6f 72 74 29 29 ata) host-port))
60f0: 0a 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 .. (hash-ta
6100: 62 6c 65 2d 73 65 74 21 20 28 75 64 61 74 2d 70 ble-set! (udat-p
6110: 65 65 72 73 20 75 64 61 74 61 29 20 68 6f 73 74 eers udata) host
6120: 2d 70 6f 72 74 20 70 65 65 72 29 29 20 3b 3b 20 -port peer)) ;;
6130: 73 61 76 65 20 74 68 65 20 64 65 74 61 69 6c 73 save the details
6140: 20 6f 66 20 74 68 69 73 20 63 61 6c 6c 65 72 20 of this caller
6150: 69 6e 20 70 65 65 72 73 0a 09 20 20 71 72 79 6b in peers.. qryk
6160: 65 79 29 29 20 3b 3b 20 45 6e 64 20 6f 66 20 70 ey)) ;; End of p
6170: 69 6e 67 0a 20 20 20 20 20 20 20 28 28 67 6f 6f ing. ((goo
6180: 64 62 79 65 29 0a 09 3b 3b 20 72 65 6d 6f 76 65 dbye)..;; remove
6190: 20 61 6c 6c 20 74 72 61 63 65 73 20 6f 66 20 74 all traces of t
61a0: 68 65 20 63 61 6c 6c 65 72 20 69 6e 20 64 62 20 he caller in db
61b0: 6f 77 6e 65 72 73 68 69 70 20 65 74 63 2e 0a 09 ownership etc...
61c0: 28 6c 65 74 2a 20 28 28 70 65 65 72 20 20 28 68 (let* ((peer (h
61d0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
61e0: 66 61 75 6c 74 20 28 75 64 61 74 2d 70 65 65 72 fault (udat-peer
61f0: 73 20 75 64 61 74 61 29 20 68 6f 73 74 2d 70 6f s udata) host-po
6200: 72 74 20 23 66 29 29 0a 09 20 20 20 20 20 20 20 rt #f))..
6210: 28 64 62 73 20 20 20 28 69 66 20 70 65 65 72 20 (dbs (if peer
6220: 28 70 65 65 72 2d 64 62 73 20 70 65 65 72 29 20 (peer-dbs peer)
6230: 27 28 29 29 29 0a 09 20 20 20 20 20 20 20 28 64 '())).. (d
6240: 62 73 68 61 73 68 20 28 75 64 61 74 2d 64 62 6f bshash (udat-dbo
6250: 77 6e 65 72 73 20 75 64 61 74 61 29 29 29 0a 09 wners udata)))..
6260: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
6270: 62 64 61 20 28 64 62 66 69 6c 65 29 28 68 61 73 bda (dbfile)(has
6280: 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
6290: 64 62 73 68 61 73 68 20 64 62 66 69 6c 65 29 29 dbshash dbfile))
62a0: 20 64 62 73 29 0a 09 20 20 28 68 61 73 68 2d 74 dbs).. (hash-t
62b0: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 75 64 able-delete! (ud
62c0: 61 74 2d 70 65 65 72 73 20 75 64 61 74 61 29 20 at-peers udata)
62d0: 68 6f 73 74 2d 70 6f 72 74 29 0a 09 20 20 71 72 host-port).. qr
62e0: 79 6b 65 79 29 29 0a 20 20 20 20 20 20 20 28 28 ykey)). ((
62f0: 64 72 6f 70 63 61 70 74 61 69 6e 29 0a 09 3b 3b dropcaptain)..;;
6300: 20 72 65 6d 6f 76 65 20 61 6c 6c 20 74 72 61 63 remove all trac
6310: 65 73 20 6f 66 20 74 68 65 20 63 61 70 74 61 69 es of the captai
6320: 6e 0a 09 28 75 64 61 74 2d 63 61 70 74 61 69 6e n..(udat-captain
6330: 2d 61 64 64 72 65 73 73 2d 73 65 74 21 20 75 64 -address-set! ud
6340: 61 74 61 20 23 66 29 0a 09 28 75 64 61 74 2d 63 ata #f)..(udat-c
6350: 61 70 74 61 69 6e 2d 68 6f 73 74 2d 73 65 74 21 aptain-host-set!
6360: 20 20 20 20 75 64 61 74 61 20 23 66 29 0a 09 28 udata #f)..(
6370: 75 64 61 74 2d 63 61 70 74 61 69 6e 2d 70 6f 72 udat-captain-por
6380: 74 2d 73 65 74 21 20 20 20 20 75 64 61 74 61 20 t-set! udata
6390: 23 66 29 0a 09 28 75 64 61 74 2d 63 61 70 74 61 #f)..(udat-capta
63a0: 69 6e 2d 70 69 64 2d 73 65 74 21 20 20 20 20 20 in-pid-set!
63b0: 75 64 61 74 61 20 23 66 29 0a 09 71 72 79 6b 65 udata #f)..qryke
63c0: 79 29 0a 20 20 20 20 20 20 20 28 28 72 75 63 61 y). ((ruca
63d0: 70 74 61 69 6e 29 20 3b 3b 20 72 65 6d 6f 74 65 ptain) ;; remote
63e0: 20 69 73 20 61 73 6b 69 6e 67 20 69 66 20 49 27 is asking if I'
63f0: 6d 20 74 68 65 20 63 61 70 74 61 69 6e 0a 09 28 m the captain..(
6400: 69 66 20 28 75 64 61 74 2d 6d 79 2d 63 70 6b 74 if (udat-my-cpkt
6410: 2d 6b 65 79 20 75 64 61 74 61 29 20 22 79 65 73 -key udata) "yes
6420: 22 20 22 6e 6f 22 29 29 0a 20 20 20 20 20 20 20 " "no")).
6430: 28 28 64 62 2d 6f 77 6e 65 72 29 20 3b 3b 20 67 ((db-owner) ;; g
6440: 69 76 65 6e 20 61 20 64 62 20 6e 61 6d 65 20 77 iven a db name w
6450: 68 6f 20 64 6f 20 49 20 73 65 6e 64 20 6d 79 20 ho do I send my
6460: 71 75 65 72 69 65 73 20 74 6f 0a 09 3b 3b 20 6c queries to..;; l
6470: 6f 6f 6b 20 75 70 20 74 68 65 20 66 69 6c 65 20 ook up the file
6480: 69 6e 20 68 61 6e 64 6c 65 72 73 2c 20 69 66 20 in handlers, if
6490: 68 61 76 65 20 61 6e 20 65 6e 74 72 79 20 70 69 have an entry pi
64a0: 6e 67 20 74 68 65 6d 20 74 6f 20 62 65 20 73 75 ng them to be su
64b0: 72 65 0a 09 3b 3b 20 74 68 65 79 20 61 72 65 20 re..;; they are
64c0: 73 74 69 6c 6c 20 61 6c 69 76 65 20 61 6e 64 20 still alive and
64d0: 74 68 65 6e 20 72 65 74 75 72 6e 20 74 68 61 74 then return that
64e0: 20 68 6f 73 74 3a 70 6f 72 74 2e 0a 09 3b 3b 20 host:port...;;
64f0: 69 66 20 6e 6f 20 68 61 6e 64 6c 65 72 20 66 6f if no handler fo
6500: 75 6e 64 20 6f 72 20 69 66 20 74 68 65 20 70 69 und or if the pi
6510: 6e 67 20 66 61 69 6c 73 20 70 69 63 6b 20 66 72 ng fails pick fr
6520: 6f 6d 20 70 65 65 72 73 20 74 68 65 20 6f 6c 64 om peers the old
6530: 65 73 74 20 74 68 61 74 0a 09 3b 3b 20 69 73 20 est that..;; is
6540: 6d 61 6e 61 67 69 6e 67 20 74 68 65 20 66 65 77 managing the few
6550: 65 73 74 20 64 62 73 0a 09 28 6d 61 74 63 68 20 est dbs..(match
6560: 70 61 72 61 6d 73 0a 09 20 20 28 28 64 62 66 69 params.. ((dbfi
6570: 6c 65 20 64 62 74 79 70 65 29 0a 09 20 20 20 28 le dbtype).. (
6580: 6c 65 74 2a 20 28 28 6f 77 6e 65 72 2d 68 6f 73 let* ((owner-hos
6590: 74 2d 70 6f 72 74 20 28 68 61 73 68 2d 74 61 62 t-port (hash-tab
65a0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
65b0: 75 64 61 74 2d 64 62 6f 77 6e 65 72 73 20 75 64 udat-dbowners ud
65c0: 61 74 61 29 20 64 62 66 69 6c 65 20 23 66 29 29 ata) dbfile #f))
65d0: 29 0a 09 20 20 20 20 20 28 69 66 20 6f 77 6e 65 ).. (if owne
65e0: 72 2d 68 6f 73 74 2d 70 6f 72 74 0a 09 09 20 28 r-host-port... (
65f0: 63 6f 6e 63 20 71 72 79 6b 65 79 20 22 20 22 20 conc qrykey " "
6600: 6f 77 6e 65 72 2d 68 6f 73 74 2d 70 6f 72 74 29 owner-host-port)
6610: 0a 09 09 20 28 6c 65 74 2a 20 28 28 70 64 61 74 ... (let* ((pdat
6620: 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 (or (hash-table
6630: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 75 64 -ref/default (ud
6640: 61 74 2d 70 65 65 72 73 20 75 64 61 74 61 29 20 at-peers udata)
6650: 68 6f 73 74 2d 70 6f 72 74 20 23 66 29 20 3b 3b host-port #f) ;;
6660: 20 6e 6f 20 6f 77 6e 65 72 20 2d 20 63 61 6c 6c no owner - call
6670: 65 72 20 67 65 74 73 20 74 6f 20 6f 77 6e 20 69 er gets to own i
6680: 74 21 0a 09 09 09 09 20 20 28 6d 61 6b 65 2d 70 t!..... (make-p
6690: 65 65 72 20 61 64 64 72 2d 70 6f 72 74 3a 20 68 eer addr-port: h
66a0: 6f 73 74 2d 70 6f 72 74 20 70 69 64 3a 20 70 69 ost-port pid: pi
66b0: 64 20 64 62 73 3a 20 60 28 2c 64 62 66 69 6c 65 d dbs: `(,dbfile
66c0: 29 29 29 29 29 0a 09 09 20 20 20 28 68 61 73 68 )))))... (hash
66d0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 75 64 61 -table-set! (uda
66e0: 74 2d 70 65 65 72 73 20 75 64 61 74 61 29 20 68 t-peers udata) h
66f0: 6f 73 74 2d 70 6f 72 74 20 70 64 61 74 29 0a 09 ost-port pdat)..
6700: 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
6710: 73 65 74 21 20 28 75 64 61 74 2d 64 62 6f 77 6e set! (udat-dbown
6720: 65 72 73 20 75 64 61 74 61 29 20 64 62 66 69 6c ers udata) dbfil
6730: 65 20 68 6f 73 74 2d 70 6f 72 74 29 0a 09 09 20 e host-port)...
6740: 20 20 28 63 6f 6e 63 20 71 72 79 6b 65 79 20 22 (conc qrykey "
6750: 20 22 20 68 6f 73 74 2d 70 6f 72 74 29 29 29 29 " host-port))))
6760: 29 0a 09 20 20 28 65 6c 73 65 20 28 63 6f 6e 63 ).. (else (conc
6770: 20 71 72 79 6b 65 79 20 22 20 42 41 44 44 41 54 qrykey " BADDAT
6780: 41 22 29 29 29 29 0a 20 20 20 20 20 20 20 3b 3b A")))). ;;
6790: 20 66 6f 72 20 77 6f 72 6b 20 69 74 65 6d 73 3a for work items:
67a0: 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 68 61 . ;; ha
67b0: 6e 64 6c 65 72 20 69 73 20 6f 6e 65 20 6f 66 3b ndler is one of;
67c0: 20 69 6d 6d 65 64 69 61 74 65 2c 20 72 65 61 64 immediate, read
67d0: 2d 6f 6e 6c 79 2c 20 72 65 61 64 2d 77 72 69 74 -only, read-writ
67e0: 65 2c 20 68 69 67 68 2d 70 72 69 6f 72 69 74 79 e, high-priority
67f0: 0a 20 20 20 20 20 20 20 28 28 69 6d 6d 65 64 69 . ((immedi
6800: 61 74 65 20 72 65 61 64 2d 6f 6e 6c 79 20 6e 6f ate read-only no
6810: 72 6d 61 6c 20 6c 6f 77 2d 70 72 69 6f 72 69 74 rmal low-priorit
6820: 79 29 20 3b 3b 20 64 6f 20 74 68 69 73 20 77 6f y) ;; do this wo
6830: 72 6b 20 69 6d 6d 65 64 69 61 74 65 6c 79 0a 09 rk immediately..
6840: 3b 3b 20 68 6f 73 74 2d 70 6f 72 74 20 28 63 61 ;; host-port (ca
6850: 6c 6c 65 72 29 2c 20 70 69 64 20 28 63 61 6c 6c ller), pid (call
6860: 65 72 29 2c 20 71 72 79 6b 65 79 20 28 63 6f 6f er), qrykey (coo
6870: 6b 69 65 29 2c 20 70 61 72 61 6d 73 20 3c 3d 20 kie), params <=
6880: 61 6c 6c 20 66 72 6f 6d 20 66 69 72 73 74 20 6c all from first l
6890: 69 6e 65 0a 09 3b 3b 20 64 61 74 61 20 3d 3e 20 ine..;; data =>
68a0: 61 20 73 69 6e 67 6c 65 20 6c 69 6e 65 20 65 6e a single line en
68b0: 63 6f 64 65 64 20 68 6f 77 65 76 65 72 20 79 6f coded however yo
68c0: 75 20 77 61 6e 74 2c 20 6f 72 20 73 68 6f 75 6c u want, or shoul
68d0: 64 20 49 20 62 75 69 6c 64 20 6a 73 6f 6e 20 69 d I build json i
68e0: 6e 74 6f 20 69 74 3f 0a 09 28 70 72 69 6e 74 20 nto it?..(print
68f0: 22 68 61 6e 64 6c 65 72 6b 65 79 3d 22 20 68 61 "handlerkey=" ha
6900: 6e 64 6c 65 72 6b 65 79 29 0a 09 28 6c 65 74 2a ndlerkey)..(let*
6910: 20 28 28 70 64 61 74 20 28 67 65 74 2d 70 65 65 ((pdat (get-pee
6920: 72 2d 64 61 74 20 75 64 61 74 61 20 68 6f 73 74 r-dat udata host
6930: 2d 70 6f 72 74 29 29 29 0a 09 20 20 28 6d 61 74 -port))).. (mat
6940: 63 68 20 70 61 72 61 6d 73 20 3b 3b 20 64 62 66 ch params ;; dbf
6950: 69 6c 65 20 70 72 6f 63 6b 65 79 20 70 72 6f 63 ile prockey proc
6960: 70 61 72 61 6d 0a 09 20 20 20 20 28 28 64 62 66 param.. ((dbf
6970: 69 6c 65 20 70 72 6f 63 6b 65 79 20 70 72 6f 63 ile prockey proc
6980: 70 61 72 61 6d 29 0a 09 20 20 20 20 20 28 63 61 param).. (ca
6990: 73 65 20 68 61 6e 64 6c 65 72 6b 65 79 0a 09 20 se handlerkey..
69a0: 20 20 20 20 20 20 28 28 69 6d 6d 65 64 69 61 74 ((immediat
69b0: 65 20 72 65 61 64 2d 6f 6e 6c 79 29 0a 09 09 28 e read-only)...(
69c0: 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 20 process-request
69d0: 75 64 61 74 61 20 70 64 61 74 20 64 62 66 69 6c udata pdat dbfil
69e0: 65 20 71 72 79 6b 65 79 20 70 72 6f 63 6b 65 79 e qrykey prockey
69f0: 20 70 72 6f 63 70 61 72 61 6d 20 64 61 74 61 29 procparam data)
6a00: 29 0a 09 20 20 20 20 20 20 20 28 28 6e 6f 72 6d ).. ((norm
6a10: 61 6c 20 6c 6f 77 2d 70 72 69 6f 72 69 74 79 29 al low-priority)
6a20: 20 3b 3b 20 73 70 6c 69 74 20 6f 66 66 20 6c 61 ;; split off la
6a30: 74 65 72 20 61 6e 64 20 61 64 64 20 6c 6f 67 69 ter and add logi
6a40: 63 20 74 6f 20 73 75 70 70 6f 72 74 20 6c 6f 77 c to support low
6a50: 20 70 72 69 6f 72 69 74 79 0a 09 09 28 61 64 64 priority...(add
6a60: 2d 74 6f 2d 77 6f 72 6b 2d 71 75 65 75 65 20 75 -to-work-queue u
6a70: 64 61 74 61 20 70 64 61 74 20 64 62 66 69 6c 65 data pdat dbfile
6a80: 20 71 72 79 6b 65 79 20 70 72 6f 63 6b 65 79 20 qrykey prockey
6a90: 70 72 6f 63 70 61 72 61 6d 20 64 61 74 61 29 29 procparam data))
6aa0: 0a 09 20 20 20 20 20 20 20 28 65 6c 73 65 0a 09 .. (else..
6ab0: 09 23 66 29 29 29 0a 09 20 20 20 20 28 65 6c 73 .#f))).. (els
6ac0: 65 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 e.. (print "
6ad0: 49 4e 46 4f 3a 20 70 61 72 61 6d 73 3d 22 20 70 INFO: params=" p
6ae0: 61 72 61 6d 73 20 22 20 68 61 6e 64 6c 65 72 6b arams " handlerk
6af0: 65 79 3d 22 20 68 61 6e 64 6c 65 72 6b 65 79 20 ey=" handlerkey
6b00: 22 20 63 6f 6e 74 72 6f 6c 64 61 74 3d 22 20 63 " controldat=" c
6b10: 6f 6e 74 72 6f 6c 64 61 74 29 0a 09 20 20 20 20 ontroldat)..
6b20: 20 23 66 29 29 29 29 0a 20 20 20 20 20 20 20 28 #f)))). (
6b30: 65 6c 73 65 0a 09 3b 3b 20 28 61 64 64 2d 74 6f else..;; (add-to
6b40: 2d 77 6f 72 6b 2d 71 75 65 75 65 20 75 64 61 74 -work-queue udat
6b50: 61 20 28 67 65 74 2d 70 65 65 72 2d 64 61 74 20 a (get-peer-dat
6b60: 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 29 udata host-port)
6b70: 20 68 61 6e 64 6c 65 72 6b 65 79 20 71 72 79 6b handlerkey qryk
6b80: 65 79 20 64 61 74 61 29 0a 09 23 66 29 29 29 0a ey data)..#f))).
6b90: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 28 (else. (
6ba0: 70 72 69 6e 74 20 22 42 41 44 20 44 41 54 41 3f print "BAD DATA?
6bb0: 20 63 6f 6e 74 72 6f 6c 64 61 74 3d 22 20 63 6f controldat=" co
6bc0: 6e 74 72 6f 6c 64 61 74 20 22 20 64 61 74 61 3d ntroldat " data=
6bd0: 22 20 64 61 74 61 29 0a 20 20 20 20 20 23 66 29 " data). #f)
6be0: 29 29 3b 3b 20 68 61 6e 64 6c 65 73 20 74 68 65 ));; handles the
6bf0: 20 69 6e 63 6f 6d 69 6e 67 20 6d 65 73 73 61 67 incoming messag
6c00: 65 73 20 61 6e 64 20 64 69 73 70 61 74 63 68 65 es and dispatche
6c10: 73 20 74 6f 20 71 75 65 75 65 73 0a 0a 3b 3b 0a s to queues..;;.
6c20: 28 64 65 66 69 6e 65 20 28 75 6c 65 78 2d 68 61 (define (ulex-ha
6c30: 6e 64 6c 65 72 2d 6c 6f 6f 70 20 75 64 61 74 61 ndler-loop udata
6c40: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 ). (let* ((serv
6c50: 2d 6c 69 73 74 65 6e 65 72 20 28 75 64 61 74 2d -listener (udat-
6c60: 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 75 64 serv-listener ud
6c70: 61 74 61 29 29 29 0a 20 20 20 20 3b 3b 20 64 61 ata))). ;; da
6c80: 74 61 20 63 6f 6d 65 73 20 61 73 20 74 77 6f 20 ta comes as two
6c90: 6c 69 6e 65 73 0a 20 20 20 20 3b 3b 20 20 20 68 lines. ;; h
6ca0: 61 6e 64 6c 65 72 6b 65 79 20 72 65 73 70 2d 61 andlerkey resp-a
6cb0: 64 64 72 3a 72 65 73 70 2d 70 6f 72 74 20 68 6f ddr:resp-port ho
6cc0: 73 74 6e 61 6d 65 20 70 69 64 20 71 72 79 6b 65 stname pid qryke
6cd0: 79 20 5b 64 62 70 61 74 68 2f 64 62 66 69 6c 65 y [dbpath/dbfile
6ce0: 2e 64 62 5d 0a 20 20 20 20 3b 3b 20 20 20 64 61 .db]. ;; da
6cf0: 74 61 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 ta. (let loop
6d00: 20 28 28 73 74 61 74 65 20 27 73 74 61 72 74 29 ((state 'start)
6d10: 29 0a 20 20 20 20 20 20 28 6c 65 74 2d 76 61 6c ). (let-val
6d20: 75 65 73 20 28 28 28 69 6e 70 20 6f 75 70 29 28 ues (((inp oup)(
6d30: 74 63 70 2d 61 63 63 65 70 74 20 73 65 72 76 2d tcp-accept serv-
6d40: 6c 69 73 74 65 6e 65 72 29 29 29 0a 09 28 6c 65 listener)))..(le
6d50: 74 2a 20 28 28 63 6f 6e 74 72 6f 6c 64 61 74 20 t* ((controldat
6d60: 28 72 65 61 64 20 69 6e 70 29 29 0a 09 20 20 20 (read inp))..
6d70: 20 20 20 20 28 64 61 74 61 20 20 20 20 20 20 20 (data
6d80: 28 72 65 61 64 20 69 6e 70 29 29 0a 09 20 20 20 (read inp))..
6d90: 20 20 20 20 28 72 65 73 70 20 20 20 20 20 20 20 (resp
6da0: 28 75 6c 65 78 2d 68 61 6e 64 6c 65 72 20 75 64 (ulex-handler ud
6db0: 61 74 61 20 63 6f 6e 74 72 6f 6c 64 61 74 20 64 ata controldat d
6dc0: 61 74 61 29 29 29 0a 09 20 20 28 69 66 20 72 65 ata))).. (if re
6dd0: 73 70 20 28 77 72 69 74 65 20 72 65 73 70 20 6f sp (write resp o
6de0: 75 70 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 up)).. (close-i
6df0: 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 09 nput-port inp)..
6e00: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
6e10: 70 6f 72 74 20 6f 75 70 29 29 0a 09 28 6c 6f 6f port oup))..(loo
6e20: 70 20 73 74 61 74 65 29 29 29 29 29 0a 0a 3b 3b p state)))))..;;
6e30: 20 61 64 64 20 61 20 70 72 6f 63 20 74 6f 20 74 add a proc to t
6e40: 68 65 20 68 61 6e 64 6c 65 72 20 6c 69 73 74 2c he handler list,
6e50: 20 74 68 65 73 65 20 61 72 65 20 64 6f 6e 65 20 these are done
6e60: 73 79 6d 65 74 72 69 63 61 6c 6c 79 20 28 69 2e symetrically (i.
6e70: 65 2e 20 69 6e 20 61 6c 6c 20 69 6e 73 74 61 6e e. in all instan
6e80: 63 65 73 29 0a 3b 3b 20 73 6f 20 74 68 61 74 20 ces).;; so that
6e90: 74 68 65 20 70 72 6f 63 20 63 61 6e 20 62 65 20 the proc can be
6ea0: 64 65 72 65 66 65 72 65 6e 63 65 64 20 72 65 6d dereferenced rem
6eb0: 6f 74 65 6c 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 otely.;;.(define
6ec0: 20 28 72 65 67 69 73 74 65 72 2d 68 61 6e 64 6c (register-handl
6ed0: 65 72 20 75 64 61 74 61 20 6b 65 79 20 70 72 6f er udata key pro
6ee0: 63 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 c). (hash-table
6ef0: 2d 73 65 74 21 20 28 75 64 61 74 2d 68 61 6e 64 -set! (udat-hand
6f00: 6c 65 72 73 20 75 64 61 74 61 29 20 6b 65 79 20 lers udata) key
6f10: 70 72 6f 63 29 29 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d proc))...;;=====
6f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f60: 3d 0a 3b 3b 20 77 6f 72 6b 20 71 75 65 75 65 73 =.;; work queues
6f70: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
6f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
6fc0: 6e 65 20 28 61 64 64 2d 74 6f 2d 77 6f 72 6b 2d ne (add-to-work-
6fd0: 71 75 65 75 65 20 75 64 61 74 61 20 70 65 65 72 queue udata peer
6fe0: 2d 64 61 74 20 68 61 6e 64 6c 65 72 6b 65 79 20 -dat handlerkey
6ff0: 71 72 79 6b 65 79 20 64 61 74 61 29 0a 20 20 28 qrykey data). (
7000: 6c 65 74 20 28 28 77 64 61 74 20 28 6d 61 6b 65 let ((wdat (make
7010: 2d 77 6f 72 6b 20 70 65 65 72 2d 64 61 74 3a 20 -work peer-dat:
7020: 70 65 65 72 2d 64 61 74 20 68 61 6e 64 6c 65 72 peer-dat handler
7030: 6b 65 79 3a 20 68 61 6e 64 6c 65 72 6b 65 79 20 key: handlerkey
7040: 71 72 79 6b 65 79 3a 20 71 72 79 6b 65 79 20 64 qrykey: qrykey d
7050: 61 74 61 3a 20 64 61 74 61 29 29 29 0a 20 20 20 ata: data))).
7060: 20 28 69 66 20 28 75 64 61 74 2d 62 75 73 79 20 (if (udat-busy
7070: 75 64 61 74 61 29 0a 09 28 71 75 65 75 65 2d 61 udata)..(queue-a
7080: 64 64 21 20 28 75 64 61 74 2d 77 6f 72 6b 2d 71 dd! (udat-work-q
7090: 75 65 75 65 20 75 64 61 74 61 29 20 77 64 61 74 ueue udata) wdat
70a0: 29 0a 09 28 70 72 6f 63 65 73 73 2d 77 6f 72 6b )..(process-work
70b0: 20 75 64 61 74 61 20 77 64 61 74 29 29 20 3b 3b udata wdat)) ;;
70c0: 20 70 61 73 73 69 6e 67 20 69 6e 20 77 64 61 74 passing in wdat
70d0: 20 74 65 6c 6c 73 20 70 72 6f 63 65 73 73 2d 77 tells process-w
70e0: 6f 72 6b 20 74 6f 20 66 69 72 73 74 20 70 72 6f ork to first pro
70f0: 63 65 73 73 20 74 68 65 20 70 61 73 73 65 64 20 cess the passed
7100: 69 6e 20 77 64 61 74 0a 20 20 20 20 29 29 0a 0a in wdat. ))..
7110: 28 64 65 66 69 6e 65 20 28 64 6f 2d 77 6f 72 6b (define (do-work
7120: 20 75 64 61 74 61 20 77 64 61 74 29 0a 20 20 23 udata wdat). #
7130: 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f f)..(define (pro
7140: 63 65 73 73 2d 77 6f 72 6b 20 75 64 61 74 61 20 cess-work udata
7150: 23 21 6f 70 74 69 6f 6e 61 6c 20 77 64 61 74 29 #!optional wdat)
7160: 0a 20 20 28 69 66 20 77 64 61 74 20 28 64 6f 2d . (if wdat (do-
7170: 77 6f 72 6b 20 75 64 61 74 61 20 77 64 61 74 29 work udata wdat)
7180: 29 20 3b 3b 20 70 72 6f 63 65 73 73 20 77 64 61 ) ;; process wda
7190: 74 0a 20 20 28 6c 65 74 20 28 28 77 71 75 65 75 t. (let ((wqueu
71a0: 65 20 28 75 64 61 74 2d 77 6f 72 6b 2d 71 75 65 e (udat-work-que
71b0: 75 65 20 75 64 61 74 61 29 29 29 0a 20 20 20 20 ue udata))).
71c0: 28 69 66 20 28 6e 6f 74 20 28 71 75 65 75 65 2d (if (not (queue-
71d0: 65 6d 70 74 79 3f 20 77 71 75 65 75 65 29 29 0a empty? wqueue)).
71e0: 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 77 64 20 .(let loop ((wd
71f0: 28 71 75 65 75 65 2d 72 65 6d 6f 76 65 21 20 77 (queue-remove! w
7200: 71 75 65 75 65 29 29 29 0a 09 20 20 28 64 6f 2d queue))).. (do-
7210: 77 6f 72 6b 20 75 64 61 74 61 20 77 64 29 0a 09 work udata wd)..
7220: 20 20 28 69 66 20 28 6e 6f 74 20 28 71 75 65 75 (if (not (queu
7230: 65 2d 65 6d 70 74 79 3f 20 77 71 75 65 75 65 29 e-empty? wqueue)
7240: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ).. (loop (
7250: 71 75 65 75 65 2d 72 65 6d 6f 76 65 21 20 77 71 queue-remove! wq
7260: 75 65 75 65 29 29 29 29 29 29 29 0a 0a 3b 3b 3d ueue)))))))..;;=
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 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
72a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
72b0: 3d 3d 3d 3d 3d 0a 3b 3b 20 47 65 6e 65 72 69 63 =====.;; Generic
72c0: 20 64 62 20 68 61 6e 64 6c 69 6e 67 0a 3b 3b 20 db handling.;;
72d0: 20 20 73 65 74 75 70 20 61 20 69 6e 6d 65 6d 20 setup a inmem
72e0: 64 62 20 69 6e 73 74 61 6e 63 65 0a 3b 3b 20 20 db instance.;;
72f0: 20 6f 70 65 6e 20 63 6f 6e 6e 65 63 74 69 6f 6e open connection
7300: 20 74 6f 20 6f 6e 2d 64 69 73 6b 20 64 62 0a 3b to on-disk db.;
7310: 3b 20 20 20 73 79 6e 63 20 6f 6e 2d 64 69 73 6b ; sync on-disk
7320: 20 64 62 20 74 6f 20 69 6e 6d 65 6d 0a 3b 3b 20 db to inmem.;;
7330: 20 20 67 65 74 20 6c 6f 63 6b 20 69 6e 20 6f 6e get lock in on
7340: 2d 64 69 73 6b 20 64 62 20 66 6f 72 20 64 62 6f -disk db for dbo
7350: 77 6e 65 72 20 6f 66 20 74 68 69 73 20 64 62 0a wner of this db.
7360: 3b 3b 20 20 20 70 75 74 20 73 79 6e 63 2d 70 72 ;; put sync-pr
7370: 6f 63 2c 20 69 6e 69 74 2d 70 72 6f 63 2c 20 6f oc, init-proc, o
7380: 6e 2d 64 69 73 6b 20 68 61 6e 64 6c 65 2c 20 69 n-disk handle, i
7390: 6e 6d 65 6d 20 68 61 6e 64 6c 65 20 69 6e 20 64 nmem handle in d
73a0: 62 63 6f 6e 6e 20 73 74 75 63 74 0a 3b 3b 20 20 bconn stuct.;;
73b0: 20 72 65 74 75 72 6e 20 74 68 65 20 73 74 75 63 return the stuc
73c0: 74 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d t.;;============
73d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
73e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
73f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
7410: 73 74 72 75 63 74 20 64 62 63 6f 6e 6e 0a 20 20 struct dbconn.
7420: 28 66 6e 61 6d 65 20 20 23 66 29 0a 20 20 28 69 (fname #f). (i
7430: 6e 6d 65 6d 20 20 23 66 29 0a 20 20 28 63 6f 6e nmem #f). (con
7440: 6e 20 20 20 23 66 29 0a 20 20 28 73 79 6e 63 20 n #f). (sync
7450: 20 20 23 66 29 20 3b 3b 20 73 79 6e 63 20 70 72 #f) ;; sync pr
7460: 6f 63 0a 20 20 28 69 6e 69 74 20 20 20 23 66 29 oc. (init #f)
7470: 20 3b 3b 20 69 6e 69 74 20 70 72 6f 63 0a 20 20 ;; init proc.
7480: 28 6c 61 73 74 73 79 6e 63 20 28 63 75 72 72 65 (lastsync (curre
7490: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 29 nt-seconds)). )
74a0: 0a 0a 28 64 65 66 73 74 72 75 63 74 20 64 62 69 ..(defstruct dbi
74b0: 6e 66 6f 0a 20 20 28 69 6e 69 74 70 72 6f 63 20 nfo. (initproc
74c0: 23 66 29 0a 20 20 28 73 79 6e 63 70 72 6f 63 20 #f). (syncproc
74d0: 23 66 29 29 0a 0a 3b 3b 20 6f 70 65 6e 20 69 6e #f))..;; open in
74e0: 6d 65 6d 20 61 6e 64 20 64 69 73 6b 20 64 61 74 mem and disk dat
74f0: 61 62 61 73 65 0a 3b 3b 20 20 20 69 6e 69 74 20 abase.;; init
7500: 77 69 74 68 20 69 6e 69 74 70 72 6f 63 0a 3b 3b with initproc.;;
7510: 20 20 20 72 65 74 75 72 6e 20 64 62 20 73 74 72 return db str
7520: 75 63 74 0a 3b 3b 0a 3b 3b 20 20 20 61 70 70 6e uct.;;.;; appn
7530: 61 6d 65 3b 20 6d 65 67 61 74 65 73 74 2c 20 75 ame; megatest, u
7540: 6c 65 78 20 6f 72 20 73 6f 6d 65 74 68 69 6e 67 lex or something
7550: 20 65 6c 73 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e else..;;.(defin
7560: 65 20 28 73 65 74 75 70 2d 64 62 2d 63 6f 6e 6e e (setup-db-conn
7570: 65 63 74 69 6f 6e 20 75 64 61 74 61 20 66 6e 61 ection udata fna
7580: 6d 65 2d 69 6e 20 61 70 70 6e 61 6d 65 20 64 62 me-in appname db
7590: 74 79 70 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 type). (let* ((
75a0: 69 73 2d 75 6c 65 78 20 28 65 71 3f 20 61 70 70 is-ulex (eq? app
75b0: 6e 61 6d 65 20 27 75 6c 65 78 29 29 0a 09 20 28 name 'ulex)).. (
75c0: 64 62 69 6e 66 20 20 20 28 69 66 20 69 73 2d 75 dbinf (if is-u
75d0: 6c 65 78 20 3b 3b 20 75 6c 65 78 20 69 73 20 61 lex ;; ulex is a
75e0: 20 62 75 69 6c 74 2d 69 6e 20 73 70 65 63 69 61 built-in specia
75f0: 6c 20 63 61 73 65 0a 09 09 20 20 20 20 20 20 28 l case... (
7600: 6d 61 6b 65 2d 64 62 69 6e 66 6f 20 69 6e 69 74 make-dbinfo init
7610: 70 72 6f 63 3a 20 75 6c 65 78 64 62 2d 69 6e 69 proc: ulexdb-ini
7620: 74 20 73 79 6e 63 70 72 6f 63 3a 20 75 6c 65 78 t syncproc: ulex
7630: 64 62 2d 73 79 6e 63 29 0a 09 09 20 20 20 20 20 db-sync)...
7640: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
7650: 2f 64 65 66 61 75 6c 74 20 28 75 64 61 74 2d 64 /default (udat-d
7660: 62 74 79 70 65 73 20 75 64 61 74 61 29 20 64 62 btypes udata) db
7670: 74 79 70 65 20 23 66 29 29 29 0a 09 20 28 69 6e type #f))).. (in
7680: 69 74 70 72 6f 63 20 28 64 62 69 6e 66 6f 2d 69 itproc (dbinfo-i
7690: 6e 69 74 70 72 6f 63 20 64 62 69 6e 66 29 29 0a nitproc dbinf)).
76a0: 09 20 28 73 79 6e 63 70 72 6f 63 20 28 64 62 69 . (syncproc (dbi
76b0: 6e 66 6f 2d 73 79 6e 63 70 72 6f 63 20 64 62 69 nfo-syncproc dbi
76c0: 6e 66 29 29 0a 09 20 28 66 6e 61 6d 65 20 20 20 nf)).. (fname
76d0: 28 69 66 20 69 73 2d 75 6c 65 78 0a 09 09 20 20 (if is-ulex...
76e0: 20 20 20 20 28 63 6f 6e 63 20 28 75 64 61 74 2d (conc (udat-
76f0: 75 6c 65 78 2d 64 69 72 20 75 64 61 74 61 29 20 ulex-dir udata)
7700: 22 2f 75 6c 65 78 2e 64 62 22 29 0a 09 09 20 20 "/ulex.db")...
7710: 20 20 20 20 66 6e 61 6d 65 2d 69 6e 29 29 0a 09 fname-in))..
7720: 20 28 69 6e 6d 65 6d 2d 64 62 20 28 6f 70 65 6e (inmem-db (open
7730: 2d 61 6e 64 2d 69 6e 69 74 64 62 20 75 64 61 74 -and-initdb udat
7740: 61 20 23 66 20 27 69 6e 6d 65 6d 20 28 64 62 69 a #f 'inmem (dbi
7750: 6e 66 6f 2d 69 6e 69 74 70 72 6f 63 20 64 62 69 nfo-initproc dbi
7760: 6e 66 29 29 29 0a 09 20 28 64 69 73 6b 2d 64 62 nf))).. (disk-db
7770: 20 20 28 6f 70 65 6e 2d 61 6e 64 2d 69 6e 69 74 (open-and-init
7780: 64 62 20 75 64 61 74 61 20 66 6e 61 6d 65 20 27 db udata fname '
7790: 64 69 73 6b 20 28 64 62 69 6e 66 6f 2d 69 6e 69 disk (dbinfo-ini
77a0: 74 70 72 6f 63 20 64 62 69 6e 66 29 29 29 29 0a tproc dbinf)))).
77b0: 20 20 20 20 28 6d 61 6b 65 2d 64 62 63 6f 6e 6e (make-dbconn
77c0: 20 69 6e 6d 65 6d 3a 20 69 6e 6d 65 6d 2d 64 62 inmem: inmem-db
77d0: 20 63 6f 6e 6e 3a 20 64 69 73 6b 2d 64 62 20 73 conn: disk-db s
77e0: 79 6e 63 3a 20 73 79 6e 63 70 72 6f 63 20 69 6e ync: syncproc in
77f0: 69 74 3a 20 69 6e 69 74 70 72 6f 63 29 29 29 0a it: initproc))).
7800: 0a 3b 3b 20 64 65 73 74 3d 27 69 6e 6d 65 6d 20 .;; dest='inmem
7810: 6f 72 20 27 64 69 73 6b 0a 3b 3b 0a 28 64 65 66 or 'disk.;;.(def
7820: 69 6e 65 20 28 6f 70 65 6e 2d 61 6e 64 2d 69 6e ine (open-and-in
7830: 69 74 64 62 20 75 64 61 74 61 20 66 69 6c 65 6e itdb udata filen
7840: 61 6d 65 20 64 65 73 74 20 69 6e 69 74 2d 70 72 ame dest init-pr
7850: 6f 63 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 6e oc). (let* ((in
7860: 6d 65 6d 20 20 20 20 28 65 71 3f 20 64 65 73 74 mem (eq? dest
7870: 20 27 69 6e 6d 65 6d 29 29 0a 09 20 28 64 62 66 'inmem)).. (dbf
7880: 69 6c 65 20 20 20 28 69 66 20 69 6e 6d 65 6d 0a ile (if inmem.
7890: 09 09 20 20 20 20 20 20 20 22 3a 49 4e 4d 45 4d .. ":INMEM
78a0: 3a 22 0a 09 09 20 20 20 20 20 20 20 66 69 6c 65 :"... file
78b0: 6e 61 6d 65 29 29 0a 09 20 28 64 62 65 78 69 73 name)).. (dbexis
78c0: 74 73 20 28 69 66 20 69 6e 6d 65 6d 20 23 74 20 ts (if inmem #t
78d0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 (file-exists? db
78e0: 66 69 6c 65 29 29 29 0a 09 20 28 64 62 20 20 20 file))).. (db
78f0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 (sqlite3:ope
7900: 6e 2d 64 61 74 61 62 61 73 65 20 64 62 66 69 6c n-database dbfil
7910: 65 29 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 e))). (sqlite
7920: 33 3a 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 3:set-busy-handl
7930: 65 72 21 20 64 62 20 28 73 71 6c 69 74 65 33 3a er! db (sqlite3:
7940: 6d 61 6b 65 2d 62 75 73 79 2d 74 69 6d 65 6f 75 make-busy-timeou
7950: 74 20 31 33 36 30 30 30 29 29 0a 20 20 20 20 28 t 136000)). (
7960: 69 66 20 28 6e 6f 74 20 64 62 65 78 69 73 74 73 if (not dbexists
7970: 29 0a 09 28 69 6e 69 74 2d 70 72 6f 63 20 64 62 )..(init-proc db
7980: 29 29 0a 20 20 20 20 64 62 29 29 0a 0a 0a 3b 3b )). db))...;;
7990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79d0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 50 72 65 76 69 6f ======.;; Previo
79e0: 75 73 20 55 6c 65 78 20 64 62 20 73 74 75 66 66 us Ulex db stuff
79f0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
7a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
7a40: 6e 65 20 28 75 6c 65 78 64 62 2d 69 6e 69 74 20 ne (ulexdb-init
7a50: 64 62 20 69 6e 6d 65 6d 29 0a 20 20 28 73 71 6c db inmem). (sql
7a60: 69 74 65 33 3a 77 69 74 68 2d 74 72 61 6e 73 61 ite3:with-transa
7a70: 63 74 69 6f 6e 0a 20 20 20 64 62 0a 20 20 20 28 ction. db. (
7a80: 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 28 lambda (). (
7a90: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 28 for-each. (
7aa0: 6c 61 6d 62 64 61 20 28 73 74 6d 74 29 0a 09 28 lambda (stmt)..(
7ab0: 69 66 20 73 74 6d 74 20 28 73 71 6c 69 74 65 33 if stmt (sqlite3
7ac0: 3a 65 78 65 63 75 74 65 20 64 62 20 73 74 6d 74 :execute db stmt
7ad0: 29 29 29 0a 20 20 20 20 20 20 60 28 22 43 52 45 ))). `("CRE
7ae0: 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 ATE TABLE IF NOT
7af0: 20 45 58 49 53 54 53 20 70 72 6f 63 65 73 73 65 EXISTS processe
7b00: 73 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s .
7b10: 20 20 20 20 28 69 64 20 49 4e 54 45 47 45 52 20 (id INTEGER
7b20: 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 PRIMARY KEY,.
7b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 h
7b40: 6f 73 74 20 20 54 45 58 54 20 4e 4f 54 20 4e 55 ost TEXT NOT NU
7b50: 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 LL,.
7b60: 20 20 20 20 20 20 69 70 61 64 72 20 54 45 58 54 ipadr TEXT
7b70: 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 NOT NULL,.
7b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 70 6f 72 por
7b90: 74 20 20 49 4e 54 45 47 45 52 20 4e 4f 54 20 4e t INTEGER NOT N
7ba0: 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 20 ULL,.
7bb0: 20 20 20 20 20 20 20 70 69 64 20 20 20 49 4e 54 pid INT
7bc0: 45 47 45 52 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 EGER NOT NULL,.
7bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7be0: 20 72 65 67 74 69 6d 65 20 49 4e 54 45 47 45 52 regtime INTEGER
7bf0: 20 44 45 46 41 55 4c 54 20 28 73 74 72 66 74 69 DEFAULT (strfti
7c00: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c me('%s','now')),
7c10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7c20: 20 20 20 6c 61 73 74 5f 75 70 64 61 74 65 20 49 last_update I
7c30: 4e 54 45 47 45 52 20 44 45 46 41 55 4c 54 20 28 NTEGER DEFAULT (
7c40: 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
7c50: 6f 77 27 29 29 29 3b 22 0a 09 28 69 66 20 69 6e ow')));"..(if in
7c60: 6d 65 6d 0a 09 20 20 20 20 22 43 52 45 41 54 45 mem.. "CREATE
7c70: 20 54 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 TRIGGER IF NOT
7c80: 20 45 58 49 53 54 53 20 75 70 64 61 74 65 5f 70 EXISTS update_p
7c90: 72 6f 63 65 73 5f 74 72 69 67 67 65 72 20 41 46 roces_trigger AF
7ca0: 54 45 52 20 55 50 44 41 54 45 20 4f 4e 20 70 72 TER UPDATE ON pr
7cb0: 6f 63 65 73 73 65 73 0a 20 20 20 20 20 20 20 20 ocesses.
7cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cd0: 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 52 4f FOR EACH RO
7ce0: 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 W.
7cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d00: 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 20 20 BEGIN .
7d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d20: 20 20 20 20 20 20 20 20 20 55 50 44 41 54 45 20 UPDATE
7d30: 70 72 6f 63 65 73 73 65 73 20 53 45 54 20 6c 61 processes SET la
7d40: 73 74 5f 75 70 64 61 74 65 3d 28 73 74 72 66 74 st_update=(strft
7d50: 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 ime('%s','now'))
7d60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d80: 20 20 20 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 WHERE id=old
7d90: 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 20 20 20 .id;.
7da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7db0: 20 20 20 20 45 4e 44 3b 22 0a 09 20 20 20 20 23 END;".. #
7dc0: 66 29 29 29 29 29 29 0a 0a 3b 3b 20 6f 70 65 6e f))))))..;; open
7dd0: 20 64 61 74 61 62 61 73 65 73 2c 20 64 6f 20 69 databases, do i
7de0: 6e 69 74 69 61 6c 20 73 79 6e 63 0a 28 64 65 66 nitial sync.(def
7df0: 69 6e 65 20 28 75 6c 65 78 64 62 2d 73 79 6e 63 ine (ulexdb-sync
7e00: 20 64 62 63 6f 6e 6e 64 61 74 20 75 64 61 74 61 dbconndat udata
7e10: 29 0a 20 20 23 66 29 0a 0a 0a 29 20 3b 3b 20 45 ). #f)...) ;; E
7e20: 4e 44 20 4f 46 20 55 4c 45 58 0a 0a 0a 3b 3b 3b ND OF ULEX...;;;
7e30: 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;=============
7e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b =========.;;; ;;
7e80: 20 44 20 45 20 42 20 55 20 47 20 20 20 48 20 45 D E B U G H E
7e90: 20 4c 20 50 20 45 20 52 20 53 0a 3b 3b 3b 20 3b L P E R S.;;; ;
7ea0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ee0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 20 20 20 20 =======.;;;
7ef0: 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 62 .;;; (define (db
7f00: 67 3e 20 2e 20 61 72 67 73 29 0a 3b 3b 3b 20 20 g> . args).;;;
7f10: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
7f20: 2d 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 65 -port (current-e
7f30: 72 72 6f 72 2d 70 6f 72 74 29 0a 3b 3b 3b 20 20 rror-port).;;;
7f40: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b (lambda ().;;
7f50: 3b 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 ; (apply p
7f60: 72 69 6e 74 20 22 64 62 67 3e 20 22 20 61 72 67 rint "dbg> " arg
7f70: 73 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 s)))).;;; .;;; (
7f80: 64 65 66 69 6e 65 20 28 64 65 62 75 67 2d 70 70 define (debug-pp
7f90: 20 2e 20 61 72 67 73 29 0a 3b 3b 3b 20 20 20 28 . args).;;; (
7fa0: 69 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d if (get-environm
7fb0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 55 4c ent-variable "UL
7fc0: 45 58 5f 44 45 42 55 47 22 29 0a 3b 3b 3b 20 20 EX_DEBUG").;;;
7fd0: 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 (with-outpu
7fe0: 74 2d 74 6f 2d 70 6f 72 74 20 28 63 75 72 72 65 t-to-port (curre
7ff0: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 0a 3b nt-error-port).;
8000: 3b 3b 20 09 28 6c 61 6d 62 64 61 20 28 29 0a 3b ;; .(lambda ().;
8010: 3b 3b 20 09 20 20 28 61 70 70 6c 79 20 70 70 20 ;; . (apply pp
8020: 61 72 67 73 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b args))))).;;; .;
8030: 3b 3b 20 28 64 65 66 69 6e 65 20 2a 64 65 66 61 ;; (define *defa
8040: 75 6c 74 2d 64 65 62 75 67 2d 70 6f 72 74 2a 20 ult-debug-port*
8050: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
8060: 6f 72 74 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 ort)).;;; .;;; (
8070: 64 65 66 69 6e 65 20 28 73 64 62 67 3e 20 66 6e define (sdbg> fn
8080: 20 73 74 61 67 65 2d 6e 61 6d 65 20 73 74 61 67 stage-name stag
8090: 65 2d 73 74 61 72 74 20 73 74 61 67 65 2d 65 6e e-start stage-en
80a0: 64 20 73 74 61 72 74 2d 74 69 6d 65 20 2e 20 6d d start-time . m
80b0: 65 73 73 61 67 65 29 0a 3b 3b 3b 20 20 20 28 69 essage).;;; (i
80c0: 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 f (get-environme
80d0: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 55 4c 45 nt-variable "ULE
80e0: 58 5f 44 45 42 55 47 22 29 0a 3b 3b 3b 20 20 20 X_DEBUG").;;;
80f0: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
8100: 2d 74 6f 2d 70 6f 72 74 20 2a 64 65 66 61 75 6c -to-port *defaul
8110: 74 2d 64 65 62 75 67 2d 70 6f 72 74 2a 20 0a 3b t-debug-port* .;
8120: 3b 3b 20 09 28 6c 61 6d 62 64 61 20 28 29 0a 3b ;; .(lambda ().;
8130: 3b 3b 20 09 20 20 28 61 70 70 6c 79 20 70 72 69 ;; . (apply pri
8140: 6e 74 20 22 75 6c 65 78 3a 22 20 66 6e 20 22 20 nt "ulex:" fn "
8150: 22 20 73 74 61 67 65 2d 6e 61 6d 65 20 22 20 74 " stage-name " t
8160: 6f 6f 6b 20 22 20 28 2d 20 28 69 66 20 73 74 61 ook " (- (if sta
8170: 67 65 2d 65 6e 64 20 73 74 61 67 65 2d 65 6e 64 ge-end stage-end
8180: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
8190: 65 63 6f 6e 64 73 29 29 20 73 74 61 67 65 2d 73 econds)) stage-s
81a0: 74 61 72 74 29 20 22 20 6d 73 2e 20 22 0a 3b 3b tart) " ms. ".;;
81b0: 3b 20 09 09 20 28 69 66 20 73 74 61 72 74 2d 74 ; .. (if start-t
81c0: 69 6d 65 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 ime.;;; .. (
81d0: 63 6f 6e 63 20 22 74 6f 74 61 6c 20 74 69 6d 65 conc "total time
81e0: 20 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d " (- (current-m
81f0: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 illiseconds) sta
8200: 72 74 2d 74 69 6d 65 29 0a 3b 3b 3b 20 09 09 09 rt-time).;;; ...
8210: 20 20 20 22 20 6d 73 2e 22 29 0a 3b 3b 3b 20 09 " ms.").;;; .
8220: 09 20 20 20 20 20 22 22 29 0a 3b 3b 3b 20 09 09 . "").;;; ..
8230: 20 6d 65 73 73 61 67 65 0a 3b 3b 3b 20 09 09 20 message.;;; ..
8240: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
8250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8290: 3b 3b 20 4d 20 41 20 43 20 52 20 4f 20 53 0a 3b ;; M A C R O S.;
82a0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
82b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82e0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 69 75 70 20 63 =======.;; iup c
82f0: 61 6c 6c 62 61 63 6b 73 20 61 72 65 20 6e 6f 74 allbacks are not
8300: 20 64 75 6d 70 69 6e 67 20 74 68 65 20 73 74 61 dumping the sta
8310: 63 6b 2c 20 74 68 69 73 20 69 73 20 61 20 77 6f ck, this is a wo
8320: 72 6b 2d 61 72 6f 75 6e 64 0a 3b 3b 0a 0a 3b 3b rk-around.;;..;;
8330: 20 53 6f 6d 65 20 6f 66 20 74 68 65 73 65 20 72 Some of these r
8340: 6f 75 74 69 6e 65 73 20 75 73 65 3a 0a 3b 3b 0a outines use:.;;.
8350: 3b 3b 20 20 20 20 20 68 74 74 70 3a 2f 2f 77 77 ;; http://ww
8360: 77 2e 63 73 2e 74 6f 72 6f 6e 74 6f 2e 65 64 75 w.cs.toronto.edu
8370: 2f 7e 67 66 62 2f 73 63 68 65 6d 65 2f 73 69 6d /~gfb/scheme/sim
8380: 70 6c 65 2d 6d 61 63 72 6f 73 2e 68 74 6d 6c 0a ple-macros.html.
8390: 3b 3b 0a 3b 3b 20 53 79 6e 74 61 78 20 66 6f 72 ;;.;; Syntax for
83a0: 20 64 65 66 69 6e 69 6e 67 20 6d 61 63 72 6f 73 defining macros
83b0: 20 69 6e 20 61 20 73 69 6d 70 6c 65 20 73 74 79 in a simple sty
83c0: 6c 65 20 73 69 6d 69 6c 61 72 20 74 6f 20 66 75 le similar to fu
83d0: 6e 63 74 69 6f 6e 20 64 65 66 69 6e 69 74 6f 6e nction definiton
83e0: 2c 0a 3b 3b 20 20 77 68 65 6e 20 74 68 65 72 65 ,.;; when there
83f0: 20 69 73 20 61 20 73 69 6e 67 6c 65 20 70 61 74 is a single pat
8400: 74 65 72 6e 20 66 6f 72 20 74 68 65 20 61 72 67 tern for the arg
8410: 75 6d 65 6e 74 20 6c 69 73 74 20 61 6e 64 20 74 ument list and t
8420: 68 65 72 65 20 61 72 65 20 6e 6f 20 6b 65 79 77 here are no keyw
8430: 6f 72 64 73 2e 0a 3b 3b 0a 3b 3b 20 28 64 65 66 ords..;;.;; (def
8440: 69 6e 65 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 61 ine-simple-synta
8450: 78 20 28 6e 61 6d 65 20 61 72 67 20 2e 2e 2e 29 x (name arg ...)
8460: 20 62 6f 64 79 20 2e 2e 2e 29 0a 3b 3b 0a 3b 3b body ...).;;.;;
8470: 20 0a 3b 3b 20 28 64 65 66 69 6e 65 2d 73 79 6e .;; (define-syn
8480: 74 61 78 20 64 65 66 69 6e 65 2d 73 69 6d 70 6c tax define-simpl
8490: 65 2d 73 79 6e 74 61 78 0a 3b 3b 20 20 20 28 73 e-syntax.;; (s
84a0: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 3b yntax-rules ().;
84b0: 3b 20 20 20 20 20 28 28 5f 20 28 6e 61 6d 65 20 ; ((_ (name
84c0: 61 72 67 20 2e 2e 2e 29 20 62 6f 64 79 20 2e 2e arg ...) body ..
84d0: 2e 29 0a 3b 3b 20 20 20 20 20 20 28 64 65 66 69 .).;; (defi
84e0: 6e 65 2d 73 79 6e 74 61 78 20 6e 61 6d 65 20 28 ne-syntax name (
84f0: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 20 syntax-rules ()
8500: 28 28 6e 61 6d 65 20 61 72 67 20 2e 2e 2e 29 20 ((name arg ...)
8510: 28 62 65 67 69 6e 20 62 6f 64 79 20 2e 2e 2e 29 (begin body ...)
8520: 29 29 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 )))))).;; .;; (d
8530: 65 66 69 6e 65 2d 73 69 6d 70 6c 65 2d 73 79 6e efine-simple-syn
8540: 74 61 78 20 28 63 61 74 63 68 2d 61 6e 64 2d 64 tax (catch-and-d
8550: 75 6d 70 20 70 72 6f 63 20 70 72 6f 63 6e 61 6d ump proc procnam
8560: 65 29 0a 3b 3b 20 20 20 28 68 61 6e 64 6c 65 2d e).;; (handle-
8570: 65 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 exceptions.;;
8580: 20 65 78 6e 0a 3b 3b 20 20 20 20 28 62 65 67 69 exn.;; (begi
8590: 6e 0a 3b 3b 20 20 20 20 20 20 28 70 72 69 6e 74 n.;; (print
85a0: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
85b0: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
85c0: 29 0a 3b 3b 20 20 20 20 20 20 28 77 69 74 68 2d ).;; (with-
85d0: 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 output-to-port (
85e0: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
85f0: 72 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 6c rt).;; (l
8600: 61 6d 62 64 61 20 28 29 0a 3b 3b 20 20 20 20 20 ambda ().;;
8610: 20 20 20 20 20 28 70 72 69 6e 74 20 28 28 63 6f (print ((co
8620: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
8630: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
8640: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 3b message) exn)).;
8650: 3b 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e ; (prin
8660: 74 20 22 43 61 6c 6c 62 61 63 6b 20 65 72 72 6f t "Callback erro
8670: 72 20 69 6e 20 22 20 70 72 6f 63 6e 61 6d 65 29 r in " procname)
8680: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 70 72 .;; (pr
8690: 69 6e 74 20 22 46 75 6c 6c 20 63 6f 6e 64 69 74 int "Full condit
86a0: 69 6f 6e 20 69 6e 66 6f 3a 5c 6e 22 20 28 63 6f ion info:\n" (co
86b0: 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 ndition->list ex
86c0: 6e 29 29 29 29 29 0a 3b 3b 20 20 20 20 28 70 72 n))))).;; (pr
86d0: 6f 63 29 29 29 0a 3b 3b 20 0a 3b 3b 20 0a 3b 3b oc))).;; .;; .;;
86e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8720: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 20 45 20 43 ======.;; R E C
8730: 20 4f 20 52 20 44 20 53 0a 3b 3b 3d 3d 3d 3d 3d O R D S.;;=====
8740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8780: 3d 0a 0a 3b 3b 3b 20 3b 3b 20 69 6e 66 6f 72 6d =..;;; ;; inform
8790: 61 74 69 6f 6e 20 61 62 6f 75 74 20 6d 65 20 61 ation about me a
87a0: 73 20 61 20 73 65 72 76 65 72 0a 3b 3b 3b 20 3b s a server.;;; ;
87b0: 3b 0a 3b 3b 3b 20 28 64 65 66 73 74 72 75 63 74 ;.;;; (defstruct
87c0: 20 61 72 65 61 0a 3b 3b 3b 20 20 20 3b 3b 20 61 area.;;; ;; a
87d0: 62 6f 75 74 20 74 68 69 73 20 61 72 65 61 0a 3b bout this area.;
87e0: 3b 3b 20 20 20 28 75 73 65 70 6f 72 74 6c 6f 67 ;; (useportlog
87f0: 67 65 72 20 23 66 29 0a 3b 3b 3b 20 20 20 28 6c ger #f).;;; (l
8800: 6f 77 70 6f 72 74 20 20 20 20 20 20 20 33 32 37 owport 327
8810: 36 38 29 0a 3b 3b 3b 20 20 20 28 73 65 72 76 65 68).;;; (serve
8820: 72 2d 74 79 70 65 20 20 20 27 61 75 74 6f 29 20 r-type 'auto)
8830: 20 3b 3b 20 61 75 74 6f 3d 63 72 65 61 74 65 20 ;; auto=create
8840: 75 70 20 74 6f 20 66 69 76 65 20 73 65 72 76 65 up to five serve
8850: 72 73 2f 70 6b 74 73 2c 20 6d 61 69 6e 3d 63 72 rs/pkts, main=cr
8860: 65 61 74 65 20 70 6b 74 73 2c 20 70 61 73 73 69 eate pkts, passi
8870: 76 65 3d 6e 6f 20 70 6b 74 20 28 75 6e 6c 65 73 ve=no pkt (unles
8880: 73 20 74 68 65 72 65 20 61 72 65 20 6e 6f 20 70 s there are no p
8890: 6b 74 73 20 61 74 20 61 6c 6c 29 0a 3b 3b 3b 20 kts at all).;;;
88a0: 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 (conn
88b0: 20 23 66 29 0a 3b 3b 3b 20 20 20 28 70 6f 72 74 #f).;;; (port
88c0: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 3b 3b #f).;;
88d0: 3b 20 20 20 28 6d 79 61 64 64 72 20 20 20 20 20 ; (myaddr
88e0: 20 20 20 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d (get-my-best-
88f0: 61 64 64 72 65 73 73 29 29 0a 3b 3b 3b 20 20 20 address)).;;;
8900: 70 6b 74 69 64 20 20 20 20 20 20 20 20 20 20 3b pktid ;
8910: 3b 20 67 65 74 20 70 6b 74 20 66 72 6f 6d 20 68 ; get pkt from h
8920: 6f 73 74 73 20 74 61 62 6c 65 20 69 66 20 6e 65 osts table if ne
8930: 65 64 65 64 0a 3b 3b 3b 20 20 20 70 6b 74 66 69 eded.;;; pktfi
8940: 6c 65 0a 3b 3b 3b 20 20 20 70 6b 74 73 64 69 72 le.;;; pktsdir
8950: 0a 3b 3b 3b 20 20 20 64 62 64 69 72 0a 3b 3b 3b .;;; dbdir.;;;
8960: 20 20 20 28 64 62 68 61 6e 64 6c 65 73 20 20 20 (dbhandles
8970: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
8980: 6c 65 29 29 20 3b 3b 20 66 6e 61 6d 65 20 3d 3e le)) ;; fname =>
8990: 20 6c 69 73 74 2d 6f 66 2d 64 62 68 2c 20 4e 4f list-of-dbh, NO
89a0: 54 45 3a 20 53 68 6f 75 6c 64 20 72 65 61 6c 6c TE: Should reall
89b0: 79 20 6e 65 76 65 72 20 6e 65 65 64 20 6d 6f 72 y never need mor
89c0: 65 20 74 68 61 6e 20 6f 6e 65 3f 0a 3b 3b 3b 20 e than one?.;;;
89d0: 20 20 28 6d 75 74 65 78 20 20 20 20 20 20 20 20 (mutex
89e0: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 3b (make-mutex)).;
89f0: 3b 3b 20 20 20 28 72 74 61 62 6c 65 20 20 20 20 ;; (rtable
8a00: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
8a10: 61 62 6c 65 29 29 20 3b 3b 20 72 65 67 69 73 74 able)) ;; regist
8a20: 72 61 74 69 6f 6e 20 74 61 62 6c 65 20 6f 66 20 ration table of
8a30: 61 76 61 69 6c 61 62 6c 65 20 61 63 74 69 6f 6e available action
8a40: 73 0a 3b 3b 3b 20 20 20 28 64 62 73 20 20 20 20 s.;;; (dbs
8a50: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
8a60: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 66 69 6c h-table)) ;; fil
8a70: 65 6e 61 6d 65 20 3d 3e 20 72 61 6e 64 6f 6d 20 ename => random
8a80: 6e 75 6d 62 65 72 2c 20 75 73 65 64 20 66 6f 72 number, used for
8a90: 20 63 68 6f 6f 73 69 6e 67 20 77 68 61 74 20 64 choosing what d
8aa0: 62 73 20 49 20 73 65 72 76 65 0a 3b 3b 3b 20 20 bs I serve.;;;
8ab0: 20 3b 3b 20 61 62 6f 75 74 20 6f 74 68 65 72 20 ;; about other
8ac0: 73 65 72 76 65 72 73 0a 3b 3b 3b 20 20 20 28 68 servers.;;; (h
8ad0: 6f 73 74 73 20 20 20 20 20 20 20 20 20 28 6d 61 osts (ma
8ae0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
8af0: 3b 3b 20 6b 65 79 20 3d 3e 20 68 6f 73 74 64 61 ;; key => hostda
8b00: 74 0a 3b 3b 3b 20 20 20 28 68 6f 73 74 73 74 61 t.;;; (hoststa
8b10: 74 73 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 ts (make-has
8b20: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 6b 65 79 h-table)) ;; key
8b30: 20 3d 3e 20 61 6c 69 73 74 20 6f 66 20 66 6e 61 => alist of fna
8b40: 6d 65 20 3d 3e 20 28 20 71 63 6f 75 6e 74 20 2e me => ( qcount .
8b50: 20 71 74 69 6d 65 20 29 0a 3b 3b 3b 20 20 20 28 qtime ).;;; (
8b60: 72 65 71 73 20 20 20 20 20 20 20 20 20 20 28 6d reqs (m
8b70: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
8b80: 20 3b 3b 20 75 72 69 20 3d 3e 20 71 75 65 75 65 ;; uri => queue
8b90: 0a 3b 3b 3b 20 20 20 3b 3b 20 77 6f 72 6b 20 71 .;;; ;; work q
8ba0: 75 65 75 65 73 0a 3b 3b 3b 20 20 20 28 77 71 75 ueues.;;; (wqu
8bb0: 65 75 65 73 20 20 20 20 20 20 20 28 6d 61 6b 65 eues (make
8bc0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
8bd0: 20 66 6e 61 6d 65 20 3d 3e 20 71 64 61 74 0a 3b fname => qdat.;
8be0: 3b 3b 20 20 20 28 73 74 61 74 73 20 20 20 20 20 ;; (stats
8bf0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
8c00: 61 62 6c 65 29 29 20 3b 3b 20 66 6e 61 6d 65 20 able)) ;; fname
8c10: 3d 3e 20 74 6f 74 61 6c 71 75 65 72 69 65 73 0a => totalqueries.
8c20: 3b 3b 3b 20 20 20 28 6c 61 73 74 2d 73 72 76 75 ;;; (last-srvu
8c30: 70 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 p (current-se
8c40: 63 6f 6e 64 73 29 29 20 3b 3b 20 6c 61 73 74 20 conds)) ;; last
8c50: 74 69 6d 65 20 77 65 20 75 70 64 61 74 65 64 20 time we updated
8c60: 74 68 65 20 6b 6e 6f 77 6e 20 73 65 72 76 65 72 the known server
8c70: 73 0a 3b 3b 3b 20 20 20 28 63 6f 6f 6b 69 65 32 s.;;; (cookie2
8c80: 6d 62 6f 78 20 20 20 28 6d 61 6b 65 2d 68 61 73 mbox (make-has
8c90: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 6d 61 70 h-table)) ;; map
8ca0: 20 63 6f 6f 6b 69 65 20 66 6f 72 20 6f 75 74 73 cookie for outs
8cb0: 74 61 6e 64 69 6e 67 20 72 65 71 75 65 73 74 20 tanding request
8cc0: 74 6f 20 6d 61 69 6c 62 6f 78 20 6f 66 20 61 77 to mailbox of aw
8cd0: 61 69 74 69 6e 67 20 63 61 6c 6c 0a 3b 3b 3b 20 aiting call.;;;
8ce0: 20 20 28 72 65 61 64 79 20 23 66 29 0a 3b 3b 3b (ready #f).;;;
8cf0: 20 20 20 28 68 65 61 6c 74 68 20 20 20 20 20 20 (health
8d00: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
8d10: 6c 65 29 29 20 3b 3b 20 69 70 61 64 64 72 3a 70 le)) ;; ipaddr:p
8d20: 6f 72 74 20 3d 3e 20 6e 75 6d 20 66 61 69 6c 65 ort => num faile
8d30: 64 20 70 69 6e 67 73 20 73 69 6e 63 65 20 6c 61 d pings since la
8d40: 73 74 20 67 6f 6f 64 20 70 69 6e 67 0a 3b 3b 3b st good ping.;;;
8d50: 20 20 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b ).;;; .;;; ;;
8d60: 20 68 6f 73 74 20 73 74 61 74 73 0a 3b 3b 3b 20 host stats.;;;
8d70: 3b 3b 0a 3b 3b 3b 20 28 64 65 66 73 74 72 75 63 ;;.;;; (defstruc
8d80: 74 20 68 6f 73 74 64 61 74 0a 3b 3b 3b 20 20 20 t hostdat.;;;
8d90: 28 70 6b 74 20 20 20 20 20 20 23 66 29 0a 3b 3b (pkt #f).;;
8da0: 3b 20 20 20 28 64 62 6c 6f 61 64 20 20 20 28 6d ; (dbload (m
8db0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
8dc0: 20 20 3b 3b 20 22 64 62 66 69 6c 65 2e 64 62 22 ;; "dbfile.db"
8dd0: 20 3d 3e 20 71 75 65 72 69 65 73 2f 6d 69 6e 0a => queries/min.
8de0: 3b 3b 3b 20 20 20 28 68 6f 73 74 6c 6f 61 64 20 ;;; (hostload
8df0: 23 66 29 20 20 20 20 20 20 20 20 20 20 20 20 20 #f)
8e00: 20 20 20 20 3b 3b 20 6e 6f 72 6d 61 6c 69 7a 65 ;; normalize
8e10: 64 20 6c 6f 61 64 20 28 20 35 6d 69 6e 20 6c 6f d load ( 5min lo
8e20: 61 64 20 2f 20 6e 75 6d 63 70 75 73 20 29 0a 3b ad / numcpus ).;
8e30: 3b 3b 20 20 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 ;; ).;;; .;;;
8e40: 3b 3b 20 64 62 64 61 74 0a 3b 3b 3b 20 3b 3b 0a ;; dbdat.;;; ;;.
8e50: 3b 3b 3b 20 28 64 65 66 73 74 72 75 63 74 20 64 ;;; (defstruct d
8e60: 62 64 61 74 0a 3b 3b 3b 20 20 20 28 64 62 68 20 bdat.;;; (dbh
8e70: 20 20 20 23 66 29 0a 3b 3b 3b 20 20 20 28 66 6e #f).;;; (fn
8e80: 61 6d 65 20 20 23 66 29 0a 3b 3b 3b 20 20 20 28 ame #f).;;; (
8e90: 77 72 69 74 65 2d 61 63 63 65 73 73 20 23 66 29 write-access #f)
8ea0: 0a 3b 3b 3b 20 20 20 28 73 74 68 73 20 20 20 28 .;;; (sths (
8eb0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
8ec0: 29 20 20 3b 3b 20 68 61 73 68 20 6d 61 70 70 69 ) ;; hash mappi
8ed0: 6e 67 20 71 75 65 72 79 20 73 74 72 69 6e 67 73 ng query strings
8ee0: 20 74 6f 20 68 61 6e 64 6c 65 73 0a 3b 3b 3b 20 to handles.;;;
8ef0: 20 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 ).;;; .;;; ;;
8f00: 71 64 61 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 qdat.;;; ;;.;;;
8f10: 28 64 65 66 73 74 72 75 63 74 20 71 64 61 74 0a (defstruct qdat.
8f20: 3b 3b 3b 20 20 20 28 77 72 69 74 65 71 20 20 28 ;;; (writeq (
8f30: 6d 61 6b 65 2d 71 75 65 75 65 29 29 0a 3b 3b 3b make-queue)).;;;
8f40: 20 20 20 28 72 65 61 64 71 20 20 20 28 6d 61 6b (readq (mak
8f50: 65 2d 71 75 65 75 65 29 29 0a 3b 3b 3b 20 20 20 e-queue)).;;;
8f60: 28 72 77 71 20 20 20 20 20 28 6d 61 6b 65 2d 71 (rwq (make-q
8f70: 75 65 75 65 29 29 0a 3b 3b 3b 20 20 20 28 6c 6f ueue)).;;; (lo
8f80: 67 71 20 20 20 20 28 6d 61 6b 65 2d 71 75 65 75 gq (make-queu
8f90: 65 29 29 20 3b 3b 20 64 6f 20 77 65 20 6e 65 65 e)) ;; do we nee
8fa0: 64 20 61 20 71 75 65 75 65 20 66 6f 72 20 6c 6f d a queue for lo
8fb0: 67 67 69 6e 67 3f 20 79 65 73 2c 20 69 66 20 77 gging? yes, if w
8fc0: 65 20 75 73 65 20 73 71 6c 69 74 65 33 20 64 62 e use sqlite3 db
8fd0: 20 66 6f 72 20 6c 6f 67 67 69 6e 67 0a 3b 3b 3b for logging.;;;
8fe0: 20 20 20 28 6f 73 73 68 6f 72 74 20 28 6d 61 6b (osshort (mak
8ff0: 65 2d 71 75 65 75 65 29 29 0a 3b 3b 3b 20 20 20 e-queue)).;;;
9000: 28 6f 73 6c 6f 6e 67 20 20 28 6d 61 6b 65 2d 71 (oslong (make-q
9010: 75 65 75 65 29 29 0a 3b 3b 3b 20 20 20 28 6d 69 ueue)).;;; (mi
9020: 73 63 20 20 20 20 28 6d 61 6b 65 2d 71 75 65 75 sc (make-queu
9030: 65 29 29 20 3b 3b 20 75 73 65 64 20 66 6f 72 20 e)) ;; used for
9040: 74 68 69 6e 67 73 20 6c 69 6b 65 20 70 69 6e 67 things like ping
9050: 2d 66 75 6c 6c 0a 3b 3b 3b 20 20 20 29 0a 3b 3b -full.;;; ).;;
9060: 3b 20 0a 3b 3b 3b 20 3b 3b 20 63 61 6c 6c 64 61 ; .;;; ;; callda
9070: 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 t.;;; ;;.;;; (de
9080: 66 73 74 72 75 63 74 20 63 61 6c 6c 64 61 74 0a fstruct calldat.
9090: 3b 3b 3b 20 20 20 28 63 74 79 70 65 20 27 64 62 ;;; (ctype 'db
90a0: 77 72 69 74 65 29 0a 3b 3b 3b 20 20 20 28 6f 62 write).;;; (ob
90b0: 6a 20 20 20 23 66 29 20 20 20 20 20 20 20 20 20 j #f)
90c0: 20 20 20 20 20 3b 3b 20 74 68 69 73 20 77 6f 75 ;; this wou
90d0: 6c 64 20 6e 6f 72 6d 61 6c 6c 79 20 62 65 20 61 ld normally be a
90e0: 6e 20 53 51 4c 20 73 74 61 74 65 6d 65 6e 74 20 n SQL statement
90f0: 65 2e 67 2e 20 53 45 4c 45 43 54 2c 20 49 4e 53 e.g. SELECT, INS
9100: 45 52 54 20 65 74 63 2e 0a 3b 3b 3b 20 20 20 28 ERT etc..;;; (
9110: 72 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d rtime (current-m
9120: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b illiseconds))).;
9130: 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 6d 61 6b 65 20 ;; .;;; ;; make
9140: 69 74 20 61 20 67 6c 6f 62 61 6c 3f 20 57 65 6c it a global? Wel
9150: 6c 2c 20 69 74 20 69 73 20 6c 6f 63 61 6c 20 74 l, it is local t
9160: 6f 20 61 72 65 61 20 6d 6f 64 75 6c 65 0a 3b 3b o area module.;;
9170: 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 2a ; .;;; (define *
9180: 70 6b 74 73 70 65 63 2a 0a 3b 3b 3b 20 20 20 60 pktspec*.;;; `
9190: 28 28 73 65 72 76 65 72 20 28 68 6f 73 74 6e 61 ((server (hostna
91a0: 6d 65 20 2e 20 68 29 0a 3b 3b 3b 20 09 20 20 20 me . h).;;; .
91b0: 20 28 70 6f 72 74 20 20 20 20 20 2e 20 70 29 0a (port . p).
91c0: 3b 3b 3b 20 09 20 20 20 20 28 70 69 64 20 20 20 ;;; . (pid
91d0: 20 20 20 2e 20 69 29 0a 3b 3b 3b 20 09 20 20 20 . i).;;; .
91e0: 20 28 69 70 61 64 64 72 20 20 20 2e 20 61 29 0a (ipaddr . a).
91f0: 3b 3b 3b 20 09 20 20 20 20 29 0a 3b 3b 3b 20 20 ;;; . ).;;;
9200: 20 20 20 28 64 61 74 61 20 20 20 28 68 6f 73 74 (data (host
9210: 6e 61 6d 65 20 2e 20 68 29 20 20 3b 3b 20 73 65 name . h) ;; se
9220: 6e 64 65 72 20 68 6f 73 74 6e 61 6d 65 0a 3b 3b nder hostname.;;
9230: 3b 20 09 20 20 20 20 28 70 6f 72 74 20 20 20 20 ; . (port
9240: 20 2e 20 70 29 20 20 3b 3b 20 73 65 6e 64 65 72 . p) ;; sender
9250: 20 70 6f 72 74 0a 3b 3b 3b 20 09 20 20 20 20 28 port.;;; . (
9260: 69 70 61 64 64 72 20 20 20 2e 20 61 29 20 20 3b ipaddr . a) ;
9270: 3b 20 73 65 6e 64 65 72 20 69 70 0a 3b 3b 3b 20 ; sender ip.;;;
9280: 09 20 20 20 20 28 68 6f 73 74 6b 65 79 20 20 2e . (hostkey .
9290: 20 6b 29 20 20 3b 3b 20 73 65 6e 64 69 6e 67 20 k) ;; sending
92a0: 68 6f 73 74 20 6b 65 79 20 2d 20 73 74 6f 72 65 host key - store
92b0: 20 69 6e 66 6f 20 61 74 20 73 65 72 76 65 72 20 info at server
92c0: 75 6e 64 65 72 20 74 68 69 73 20 6b 65 79 0a 3b under this key.;
92d0: 3b 3b 20 09 20 20 20 20 28 73 65 72 76 6b 65 79 ;; . (servkey
92e0: 20 20 2e 20 73 29 20 20 3b 3b 20 73 65 72 76 65 . s) ;; serve
92f0: 72 20 6b 65 79 20 2d 20 74 68 69 73 20 6e 65 65 r key - this nee
9300: 64 73 20 74 6f 20 6d 61 74 63 68 20 61 74 20 73 ds to match at s
9310: 65 72 76 65 72 20 65 6e 64 20 6f 72 20 72 65 6a erver end or rej
9320: 65 63 74 20 74 68 65 20 6d 73 67 0a 3b 3b 3b 20 ect the msg.;;;
9330: 09 20 20 20 20 28 66 6f 72 6d 61 74 20 20 20 2e . (format .
9340: 20 66 29 20 20 3b 3b 20 73 62 3d 73 65 72 69 61 f) ;; sb=seria
9350: 6c 69 7a 65 64 2d 62 61 73 65 36 34 2c 20 74 3d lized-base64, t=
9360: 74 65 78 74 2c 20 73 78 3d 73 65 78 70 72 2c 20 text, sx=sexpr,
9370: 6a 3d 6a 73 6f 6e 0a 3b 3b 3b 20 09 20 20 20 20 j=json.;;; .
9380: 28 64 61 74 61 20 20 20 20 20 2e 20 64 29 20 20 (data . d)
9390: 3b 3b 20 62 61 73 65 36 34 20 65 6e 63 6f 64 65 ;; base64 encode
93a0: 64 20 73 6c 6c 6e 20 64 61 74 61 0a 3b 3b 3b 20 d slln data.;;;
93b0: 09 20 20 20 20 29 29 29 0a 3b 3b 3b 20 0a 3b 3b . ))).;;; .;;
93c0: 3b 20 3b 3b 20 77 6f 72 6b 20 69 74 65 6d 0a 3b ; ;; work item.;
93d0: 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 73 74 ;; ;;.;;; (defst
93e0: 72 75 63 74 20 77 69 74 65 6d 0a 3b 3b 3b 20 20 ruct witem.;;;
93f0: 20 28 72 68 6f 73 74 20 23 66 29 20 20 20 3b 3b (rhost #f) ;;
9400: 20 72 65 74 75 72 6e 20 68 6f 73 74 0a 3b 3b 3b return host.;;;
9410: 20 20 20 28 72 69 70 61 64 64 72 20 23 66 29 20 (ripaddr #f)
9420: 3b 3b 20 72 65 74 75 72 6e 20 69 70 61 64 64 72 ;; return ipaddr
9430: 0a 3b 3b 3b 20 20 20 28 72 70 6f 72 74 20 23 66 .;;; (rport #f
9440: 29 20 20 20 3b 3b 20 72 65 74 75 72 6e 20 70 6f ) ;; return po
9450: 72 74 0a 3b 3b 3b 20 20 20 28 73 65 72 76 6b 65 rt.;;; (servke
9460: 79 20 23 66 29 20 3b 3b 20 74 68 65 20 70 61 63 y #f) ;; the pac
9470: 6b 65 74 20 72 65 70 72 65 73 65 6e 74 69 6e 67 ket representing
9480: 20 74 68 65 20 63 6c 69 65 6e 74 20 6f 66 20 74 the client of t
9490: 68 69 73 20 77 6f 72 6b 69 74 65 6d 2c 20 75 73 his workitem, us
94a0: 65 64 20 62 79 20 66 69 6e 61 6c 20 73 65 6e 64 ed by final send
94b0: 2d 6d 65 73 73 61 67 65 0a 3b 3b 3b 20 20 20 28 -message.;;; (
94c0: 72 64 61 74 20 20 23 66 29 20 20 20 3b 3b 20 74 rdat #f) ;; t
94d0: 68 65 20 72 65 71 75 65 73 74 20 2d 20 75 73 75 he request - usu
94e0: 61 6c 6c 79 20 61 6e 20 73 71 6c 20 71 75 65 72 ally an sql quer
94f0: 79 2c 20 74 79 70 65 20 69 73 20 72 64 61 74 0a y, type is rdat.
9500: 3b 3b 3b 20 20 20 28 61 63 74 69 6f 6e 20 23 66 ;;; (action #f
9510: 29 20 20 3b 3b 20 74 68 65 20 61 63 74 69 6f 6e ) ;; the action
9520: 3a 20 69 6d 6d 65 64 69 61 74 65 2c 20 64 62 77 : immediate, dbw
9530: 72 69 74 65 2c 20 64 62 72 65 61 64 2c 6f 73 6c rite, dbread,osl
9540: 6f 6e 67 2c 20 6f 73 73 68 6f 72 74 0a 3b 3b 3b ong, osshort.;;;
9550: 20 20 20 28 63 6f 6f 6b 69 65 20 23 66 29 20 20 (cookie #f)
9560: 3b 3b 20 63 6f 6f 6b 69 65 20 69 64 20 66 6f 72 ;; cookie id for
9570: 20 72 65 73 70 6f 6e 73 65 0a 3b 3b 3b 20 20 20 response.;;;
9580: 28 64 61 74 61 20 20 20 23 66 29 20 20 3b 3b 20 (data #f) ;;
9590: 74 68 65 20 64 61 74 61 20 70 61 79 6c 6f 61 64 the data payload
95a0: 2c 20 69 2e 65 2e 20 70 61 72 61 6d 65 74 65 72 , i.e. parameter
95b0: 73 0a 3b 3b 3b 20 20 20 28 72 65 73 75 6c 74 20 s.;;; (result
95c0: 23 66 29 20 20 3b 3b 20 74 68 65 20 72 65 73 75 #f) ;; the resu
95d0: 6c 74 20 66 72 6f 6d 20 70 72 6f 63 65 73 73 69 lt from processi
95e0: 6e 67 20 74 68 65 20 64 61 74 61 0a 3b 3b 3b 20 ng the data.;;;
95f0: 20 20 28 63 61 6c 6c 65 72 20 23 66 29 29 20 3b (caller #f)) ;
9600: 3b 20 74 68 65 20 63 61 6c 6c 69 6e 67 20 70 65 ; the calling pe
9610: 65 72 20 61 63 63 6f 72 64 69 6e 67 20 74 6f 20 er according to
9620: 72 70 63 20 69 74 73 65 6c 66 0a 3b 3b 3b 20 0a rpc itself.;;; .
9630: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 72 69 ;;; (define (tri
9640: 6d 2d 70 6b 74 69 64 20 70 6b 74 69 64 29 0a 3b m-pktid pktid).;
9650: 3b 3b 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 ;; (if (string
9660: 3f 20 70 6b 74 69 64 29 0a 3b 3b 3b 20 20 20 20 ? pktid).;;;
9670: 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 70 6b (substring pk
9680: 74 69 64 20 30 20 34 29 0a 3b 3b 3b 20 20 20 20 tid 0 4).;;;
9690: 20 20 20 22 6e 6f 70 6b 74 22 29 29 0a 3b 3b 3b "nopkt")).;;;
96a0: 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 61 .;;; (define (a
96b0: 6e 79 2d 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 0a ny->number num).
96c0: 3b 3b 3b 20 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 ;;; (cond.;;;
96d0: 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 6e 75 6d ((number? num
96e0: 29 20 6e 75 6d 29 0a 3b 3b 3b 20 20 20 20 28 28 ) num).;;; ((
96f0: 73 74 72 69 6e 67 3f 20 6e 75 6d 29 20 28 73 74 string? num) (st
9700: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6e 75 6d ring->number num
9710: 29 29 0a 3b 3b 3b 20 20 20 20 28 65 6c 73 65 20 )).;;; (else
9720: 6e 75 6d 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 num))).;;; .;;;
9730: 28 75 73 65 20 74 72 61 63 65 29 0a 3b 3b 3b 20 (use trace).;;;
9740: 28 74 72 61 63 65 2d 63 61 6c 6c 2d 73 69 74 65 (trace-call-site
9750: 73 20 23 74 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b s #t).;;; .;;; ;
9760: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
9770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97a0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 44 =======.;;; ;; D
97b0: 20 41 20 54 20 41 20 42 20 41 20 53 20 45 20 20 A T A B A S E
97c0: 20 48 20 41 20 4e 20 44 20 4c 20 49 20 4e 20 47 H A N D L I N G
97d0: 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d .;;; ;;========
97e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
9820: 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 6c 6f 6f 6b 20 ;; .;;; ;; look
9830: 69 6e 20 64 62 68 61 6e 64 6c 65 73 20 66 6f 72 in dbhandles for
9840: 20 61 20 64 62 2c 20 72 65 74 75 72 6e 20 69 74 a db, return it
9850: 2c 20 65 6c 73 65 20 72 65 74 75 72 6e 20 23 66 , else return #f
9860: 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 .;;; ;;.;;; (def
9870: 69 6e 65 20 28 67 65 74 2d 64 62 68 20 61 63 66 ine (get-dbh acf
9880: 67 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 28 g fname).;;; (
9890: 6c 65 74 20 28 28 64 62 68 2d 6c 73 74 20 28 68 let ((dbh-lst (h
98a0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
98b0: 66 61 75 6c 74 20 28 61 72 65 61 2d 64 62 68 61 fault (area-dbha
98c0: 6e 64 6c 65 73 20 61 63 66 67 29 20 66 6e 61 6d ndles acfg) fnam
98d0: 65 20 27 28 29 29 29 29 0a 3b 3b 3b 20 20 20 20 e '()))).;;;
98e0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 62 68 2d (if (null? dbh-
98f0: 6c 73 74 29 0a 3b 3b 3b 20 09 28 62 65 67 69 6e lst).;;; .(begin
9900: 0a 3b 3b 3b 20 09 20 20 3b 3b 20 28 70 72 69 6e .;;; . ;; (prin
9910: 74 20 22 6f 70 65 6e 69 6e 67 20 64 62 20 66 6f t "opening db fo
9920: 72 20 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 r " fname).;;; .
9930: 20 20 28 6f 70 65 6e 2d 64 62 20 61 63 66 67 20 (open-db acfg
9940: 66 6e 61 6d 65 29 29 20 3b 3b 20 4e 6f 74 65 20 fname)) ;; Note
9950: 74 68 61 74 20 74 68 65 20 68 61 6e 64 6c 65 73 that the handles
9960: 20 67 65 74 20 70 75 74 20 62 61 63 6b 20 69 6e get put back in
9970: 20 74 68 65 20 71 75 65 75 65 20 69 6e 20 74 68 the queue in th
9980: 65 20 73 61 76 65 2d 64 62 68 20 63 61 6c 6c 73 e save-dbh calls
9990: 0a 3b 3b 3b 20 09 28 6c 65 74 20 28 28 72 65 6d .;;; .(let ((rem
99a0: 2d 6c 73 74 20 28 63 64 72 20 64 62 68 2d 6c 73 -lst (cdr dbh-ls
99b0: 74 29 29 29 0a 3b 3b 3b 20 09 20 20 3b 3b 20 28 t))).;;; . ;; (
99c0: 70 72 69 6e 74 20 22 72 65 2d 75 73 69 6e 67 20 print "re-using
99d0: 73 61 76 65 64 20 63 6f 6e 6e 65 63 74 69 6f 6e saved connection
99e0: 20 66 6f 72 20 22 20 66 6e 61 6d 65 29 0a 3b 3b for " fname).;;
99f0: 3b 20 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ; . (hash-table
9a00: 2d 73 65 74 21 20 28 61 72 65 61 2d 64 62 68 61 -set! (area-dbha
9a10: 6e 64 6c 65 73 20 61 63 66 67 29 20 66 6e 61 6d ndles acfg) fnam
9a20: 65 20 72 65 6d 2d 6c 73 74 29 0a 3b 3b 3b 20 09 e rem-lst).;;; .
9a30: 20 20 28 63 61 72 20 64 62 68 2d 6c 73 74 29 29 (car dbh-lst))
9a40: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 ))).;;; .;;; (de
9a50: 66 69 6e 65 20 28 73 61 76 65 2d 64 62 68 20 61 fine (save-dbh a
9a60: 63 66 67 20 66 6e 61 6d 65 20 64 62 64 61 74 29 cfg fname dbdat)
9a70: 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 28 70 72 69 .;;; ;; (pri
9a80: 6e 74 20 22 73 61 76 69 6e 67 20 64 62 68 20 66 nt "saving dbh f
9a90: 6f 72 20 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 or " fname).;;;
9aa0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
9ab0: 73 65 74 21 20 28 61 72 65 61 2d 64 62 68 61 6e set! (area-dbhan
9ac0: 64 6c 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 dles acfg) fname
9ad0: 20 28 63 6f 6e 73 20 64 62 64 61 74 20 28 68 61 (cons dbdat (ha
9ae0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
9af0: 61 75 6c 74 20 28 61 72 65 61 2d 64 62 68 61 6e ault (area-dbhan
9b00: 64 6c 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 dles acfg) fname
9b10: 20 27 28 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b '())))).;;; .;;
9b20: 3b 20 3b 3b 20 6f 70 65 6e 20 74 68 65 20 64 61 ; ;; open the da
9b30: 74 61 62 61 73 65 2c 20 69 66 20 6e 65 76 65 72 tabase, if never
9b40: 20 62 65 66 6f 72 65 20 6f 70 65 6e 65 64 20 69 before opened i
9b50: 6e 69 74 20 69 74 2e 20 70 75 74 20 74 68 65 20 nit it. put the
9b60: 68 61 6e 64 6c 65 20 69 6e 20 74 68 65 0a 3b 3b handle in the.;;
9b70: 3b 20 3b 3b 20 6f 70 65 6e 20 64 62 27 73 20 68 ; ;; open db's h
9b80: 61 73 68 20 74 61 62 6c 65 0a 3b 3b 3b 20 3b 3b ash table.;;; ;;
9b90: 20 72 65 74 75 72 6e 73 3a 20 74 68 65 20 64 62 returns: the db
9ba0: 64 61 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 dat.;;; ;;.;;; (
9bb0: 64 65 66 69 6e 65 20 28 6f 70 65 6e 2d 64 62 20 define (open-db
9bc0: 61 63 66 67 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 acfg fname).;;;
9bd0: 20 20 28 6c 65 74 2a 20 28 28 66 75 6c 6c 6e 61 (let* ((fullna
9be0: 6d 65 20 20 20 20 20 28 63 6f 6e 63 20 28 61 72 me (conc (ar
9bf0: 65 61 2d 64 62 64 69 72 20 61 63 66 67 29 20 22 ea-dbdir acfg) "
9c00: 2f 22 20 66 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 /" fname)).;;; .
9c10: 20 28 65 78 69 73 74 73 20 20 20 20 20 20 20 28 (exists (
9c20: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c file-exists? ful
9c30: 6c 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 28 77 lname)).;;; . (w
9c40: 72 69 74 65 2d 61 63 63 65 73 73 20 28 69 66 20 rite-access (if
9c50: 65 78 69 73 74 73 0a 3b 3b 3b 20 09 09 09 20 20 exists.;;; ...
9c60: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
9c70: 65 73 73 3f 20 66 75 6c 6c 6e 61 6d 65 29 0a 3b ess? fullname).;
9c80: 3b 3b 20 09 09 09 20 20 20 28 66 69 6c 65 2d 77 ;; ... (file-w
9c90: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 28 61 72 rite-access? (ar
9ca0: 65 61 2d 64 62 64 69 72 20 61 63 66 67 29 29 29 ea-dbdir acfg)))
9cb0: 29 0a 3b 3b 3b 20 09 20 28 64 62 20 20 20 20 20 ).;;; . (db
9cc0: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 6f (sqlite3:o
9cd0: 70 65 6e 2d 64 61 74 61 62 61 73 65 20 66 75 6c pen-database ful
9ce0: 6c 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 28 68 lname)).;;; . (h
9cf0: 61 6e 64 6c 65 72 20 20 20 20 20 20 28 73 71 6c andler (sql
9d00: 69 74 65 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 ite3:make-busy-t
9d10: 69 6d 65 6f 75 74 20 31 33 36 30 30 30 29 29 0a imeout 136000)).
9d20: 3b 3b 3b 20 09 20 29 0a 3b 3b 3b 20 20 20 20 20 ;;; . ).;;;
9d30: 28 73 71 6c 69 74 65 33 3a 73 65 74 2d 62 75 73 (sqlite3:set-bus
9d40: 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 68 61 y-handler! db ha
9d50: 6e 64 6c 65 72 29 0a 3b 3b 3b 20 20 20 20 20 28 ndler).;;; (
9d60: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
9d70: 64 62 20 22 50 52 41 47 4d 41 20 73 79 6e 63 68 db "PRAGMA synch
9d80: 72 6f 6e 6f 75 73 20 3d 20 30 3b 22 29 0a 3b 3b ronous = 0;").;;
9d90: 3b 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 65 ; (if (not e
9da0: 78 69 73 74 73 29 20 3b 3b 20 6e 65 65 64 20 74 xists) ;; need t
9db0: 6f 20 69 6e 69 74 20 74 68 65 20 64 62 0a 3b 3b o init the db.;;
9dc0: 3b 20 09 28 69 66 20 77 72 69 74 65 2d 61 63 63 ; .(if write-acc
9dd0: 65 73 73 0a 3b 3b 3b 20 09 20 20 20 20 28 6c 65 ess.;;; . (le
9de0: 74 20 28 28 69 73 71 6c 20 28 67 65 74 2d 72 73 t ((isql (get-rs
9df0: 71 6c 20 61 63 66 67 20 27 64 62 69 6e 69 74 73 ql acfg 'dbinits
9e00: 71 6c 29 29 29 20 3b 3b 20 67 65 74 20 74 68 65 ql))) ;; get the
9e10: 20 69 6e 69 74 20 73 71 6c 20 73 74 61 74 65 6d init sql statem
9e20: 65 6e 74 73 0a 3b 3b 3b 20 09 20 20 20 20 20 20 ents.;;; .
9e30: 3b 3b 20 28 73 71 6c 69 74 65 33 3a 77 69 74 68 ;; (sqlite3:with
9e40: 2d 74 72 61 6e 73 61 63 74 69 6f 6e 0a 3b 3b 3b -transaction.;;;
9e50: 20 09 20 20 20 20 20 20 3b 3b 20 20 64 62 0a 3b . ;; db.;
9e60: 3b 3b 20 09 20 20 20 20 20 20 3b 3b 20 20 28 6c ;; . ;; (l
9e70: 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 09 09 20 ambda ().;;; ..
9e80: 28 69 66 20 69 73 71 6c 0a 3b 3b 3b 20 09 09 20 (if isql.;;; ..
9e90: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b (for-each.;;
9ea0: 3b 20 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 ; .. (lambd
9eb0: 61 20 28 73 71 6c 29 0a 3b 3b 3b 20 09 09 09 28 a (sql).;;; ...(
9ec0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
9ed0: 64 62 20 73 71 6c 29 29 0a 3b 3b 3b 20 09 09 20 db sql)).;;; ..
9ee0: 20 20 20 20 20 69 73 71 6c 29 29 29 0a 3b 3b 3b isql))).;;;
9ef0: 20 09 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 . (print "ER
9f00: 52 4f 52 3a 20 6e 6f 20 77 72 69 74 65 20 61 63 ROR: no write ac
9f10: 63 65 73 73 20 74 6f 20 22 20 28 61 72 65 61 2d cess to " (area-
9f20: 64 62 64 69 72 20 61 63 66 67 29 29 29 29 0a 3b dbdir acfg)))).;
9f30: 3b 3b 20 20 20 20 20 28 6d 61 6b 65 2d 64 62 64 ;; (make-dbd
9f40: 61 74 20 64 62 68 3a 20 64 62 20 66 6e 61 6d 65 at dbh: db fname
9f50: 3a 20 66 6e 61 6d 65 20 77 72 69 74 65 2d 61 63 : fname write-ac
9f60: 63 65 73 73 3a 20 77 72 69 74 65 2d 61 63 63 65 cess: write-acce
9f70: 73 73 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b ss))).;;; .;;; ;
9f80: 3b 20 54 68 69 73 20 69 73 20 61 20 6c 6f 77 2d ; This is a low-
9f90: 6c 65 76 65 6c 20 63 6f 6d 6d 61 6e 64 20 74 6f level command to
9fa0: 20 72 65 74 72 69 65 76 65 20 6f 72 20 74 6f 20 retrieve or to
9fb0: 70 72 65 70 61 72 65 2c 20 73 61 76 65 20 61 6e prepare, save an
9fc0: 64 20 72 65 74 75 72 6e 20 61 20 70 72 65 70 61 d return a prepa
9fd0: 72 65 64 20 73 74 61 74 6d 65 6e 74 0a 3b 3b 3b red statment.;;;
9fe0: 20 3b 3b 20 79 6f 75 20 6d 75 73 74 20 65 78 74 ;; you must ext
9ff0: 72 61 63 74 20 74 68 65 20 64 62 20 68 61 6e 64 ract the db hand
a000: 6c 65 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 le.;;; ;;.;;; (d
a010: 65 66 69 6e 65 20 28 67 65 74 2d 73 74 68 20 64 efine (get-sth d
a020: 62 20 63 61 63 68 65 20 73 74 6d 74 29 0a 3b 3b b cache stmt).;;
a030: 3b 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 ; (if (hash-ta
a040: 62 6c 65 2d 65 78 69 73 74 73 3f 20 63 61 63 68 ble-exists? cach
a050: 65 20 73 74 6d 74 29 0a 3b 3b 3b 20 20 20 20 20 e stmt).;;;
a060: 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 3b 3b (begin.;;; .;;
a070: 20 28 70 72 69 6e 74 20 22 52 65 75 73 69 6e 67 (print "Reusing
a080: 20 63 61 63 68 65 64 20 73 74 6d 74 20 66 6f 72 cached stmt for
a090: 20 22 20 73 74 6d 74 29 0a 3b 3b 3b 20 09 28 68 " stmt).;;; .(h
a0a0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
a0b0: 66 61 75 6c 74 20 63 61 63 68 65 20 73 74 6d 74 fault cache stmt
a0c0: 20 23 66 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 #f)).;;;
a0d0: 28 6c 65 74 20 28 28 73 74 68 20 28 73 71 6c 69 (let ((sth (sqli
a0e0: 74 65 33 3a 70 72 65 70 61 72 65 20 64 62 20 73 te3:prepare db s
a0f0: 74 6d 74 29 29 29 0a 3b 3b 3b 20 09 28 68 61 73 tmt))).;;; .(has
a100: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 61 63 h-table-set! cac
a110: 68 65 20 73 74 6d 74 20 73 74 68 29 0a 3b 3b 3b he stmt sth).;;;
a120: 20 09 3b 3b 20 28 70 72 69 6e 74 20 22 70 72 65 .;; (print "pre
a130: 70 61 72 65 64 20 73 74 6d 74 20 66 6f 72 20 22 pared stmt for "
a140: 20 73 74 6d 74 29 0a 3b 3b 3b 20 09 73 74 68 29 stmt).;;; .sth)
a150: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 61 )).;;; .;;; ;; a
a160: 20 6c 69 74 74 6c 65 20 6d 6f 72 65 20 65 78 70 little more exp
a170: 65 6e 73 69 76 65 20 62 75 74 20 64 6f 65 73 20 ensive but does
a180: 61 6c 6c 20 74 68 65 20 74 65 64 69 6f 75 73 20 all the tedious
a190: 64 65 66 65 72 65 6e 63 69 6e 67 20 2d 20 6f 6e deferencing - on
a1a0: 6c 79 20 75 73 65 20 69 66 20 79 6f 75 20 64 6f ly use if you do
a1b0: 6e 27 74 20 61 6c 72 65 61 64 79 0a 3b 3b 3b 20 n't already.;;;
a1c0: 3b 3b 20 68 61 76 65 20 64 62 64 61 74 20 61 6e ;; have dbdat an
a1d0: 64 20 64 62 20 73 69 74 74 69 6e 67 20 61 72 6f d db sitting aro
a1e0: 75 6e 64 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 und.;;; ;;.;;; (
a1f0: 64 65 66 69 6e 65 20 28 66 75 6c 6c 2d 67 65 74 define (full-get
a200: 2d 73 74 68 20 61 63 66 67 20 66 6e 61 6d 65 20 -sth acfg fname
a210: 73 74 6d 74 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 stmt).;;; (let
a220: 2a 20 28 28 64 62 64 61 74 20 20 28 67 65 74 2d * ((dbdat (get-
a230: 64 62 68 20 61 63 66 67 20 66 6e 61 6d 65 29 29 dbh acfg fname))
a240: 0a 3b 3b 3b 20 09 20 28 64 62 20 20 20 20 20 28 .;;; . (db (
a250: 64 62 64 61 74 2d 64 62 68 20 64 62 64 61 74 29 dbdat-dbh dbdat)
a260: 29 0a 3b 3b 3b 20 09 20 28 73 74 68 73 20 20 20 ).;;; . (sths
a270: 28 64 62 64 61 74 2d 73 74 68 73 20 64 62 64 61 (dbdat-sths dbda
a280: 74 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 67 65 t))).;;; (ge
a290: 74 2d 73 74 68 20 64 62 20 73 74 68 73 20 73 74 t-sth db sths st
a2a0: 6d 74 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b mt))).;;; .;;; ;
a2b0: 3b 20 77 72 69 74 65 20 74 6f 20 61 20 64 62 0a ; write to a db.
a2c0: 3b 3b 3b 20 3b 3b 20 61 63 66 67 3a 20 61 72 65 ;;; ;; acfg: are
a2d0: 61 20 64 61 74 61 0a 3b 3b 3b 20 3b 3b 20 72 64 a data.;;; ;; rd
a2e0: 61 74 3a 20 72 65 71 75 65 73 74 20 64 61 74 61 at: request data
a2f0: 0a 3b 3b 3b 20 3b 3b 20 68 64 61 74 3a 20 28 68 .;;; ;; hdat: (h
a300: 6f 73 74 20 2e 20 70 6f 72 74 29 0a 3b 3b 3b 20 ost . port).;;;
a310: 3b 3b 0a 3b 3b 3b 20 3b 3b 20 28 64 65 66 69 6e ;;.;;; ;; (defin
a320: 65 20 28 64 62 77 72 69 74 65 20 61 63 66 67 20 e (dbwrite acfg
a330: 72 64 61 74 20 68 64 61 74 20 64 61 74 61 2d 69 rdat hdat data-i
a340: 6e 29 0a 3b 3b 3b 20 3b 3b 20 20 20 28 6c 65 74 n).;;; ;; (let
a350: 2a 20 28 28 64 62 6e 61 6d 65 20 28 63 61 72 20 * ((dbname (car
a360: 64 61 74 61 2d 69 6e 29 29 0a 3b 3b 3b 20 3b 3b data-in)).;;; ;;
a370: 20 09 20 28 64 62 64 61 74 20 20 28 67 65 74 2d . (dbdat (get-
a380: 64 62 68 20 61 63 66 67 20 64 62 6e 61 6d 65 29 dbh acfg dbname)
a390: 29 0a 3b 3b 3b 20 3b 3b 20 09 20 28 64 62 20 20 ).;;; ;; . (db
a3a0: 20 20 20 28 64 62 64 61 74 2d 64 62 68 20 64 62 (dbdat-dbh db
a3b0: 64 61 74 29 29 0a 3b 3b 3b 20 3b 3b 20 09 20 28 dat)).;;; ;; . (
a3c0: 73 74 68 73 20 20 20 28 64 62 64 61 74 2d 73 74 sths (dbdat-st
a3d0: 68 73 20 64 62 64 61 74 29 29 0a 3b 3b 3b 20 3b hs dbdat)).;;; ;
a3e0: 3b 20 09 20 28 73 74 6d 74 20 20 20 28 63 61 6c ; . (stmt (cal
a3f0: 6c 64 61 74 2d 6f 62 6a 20 72 64 61 74 29 29 0a ldat-obj rdat)).
a400: 3b 3b 3b 20 3b 3b 20 09 20 28 73 74 68 20 20 20 ;;; ;; . (sth
a410: 20 28 67 65 74 2d 73 74 68 20 64 62 20 73 74 68 (get-sth db sth
a420: 73 20 73 74 6d 74 29 29 0a 3b 3b 3b 20 3b 3b 20 s stmt)).;;; ;;
a430: 09 20 28 64 61 74 61 20 20 20 28 63 64 72 20 64 . (data (cdr d
a440: 61 74 61 2d 69 6e 29 29 29 0a 3b 3b 3b 20 3b 3b ata-in))).;;; ;;
a450: 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 6e (print "dbn
a460: 61 6d 65 3a 20 22 20 64 62 6e 61 6d 65 20 22 20 ame: " dbname "
a470: 61 63 66 67 3a 20 22 20 61 63 66 67 20 22 20 72 acfg: " acfg " r
a480: 64 61 74 3a 20 22 20 28 63 61 6c 6c 64 61 74 2d dat: " (calldat-
a490: 3e 61 6c 69 73 74 20 72 64 61 74 29 20 22 20 68 >alist rdat) " h
a4a0: 64 61 74 3a 20 22 20 68 64 61 74 20 22 20 64 61 dat: " hdat " da
a4b0: 74 61 3a 20 22 20 64 61 74 61 29 0a 3b 3b 3b 20 ta: " data).;;;
a4c0: 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 ;; (print "d
a4d0: 62 64 61 74 3a 20 22 20 28 64 62 64 61 74 2d 3e bdat: " (dbdat->
a4e0: 61 6c 69 73 74 20 64 62 64 61 74 29 29 0a 3b 3b alist dbdat)).;;
a4f0: 3b 20 3b 3b 20 20 20 20 20 28 61 70 70 6c 79 20 ; ;; (apply
a500: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
a510: 73 74 68 20 64 61 74 61 29 0a 3b 3b 3b 20 3b 3b sth data).;;; ;;
a520: 20 20 20 20 20 28 73 61 76 65 2d 64 62 68 20 61 (save-dbh a
a530: 63 66 67 20 64 62 6e 61 6d 65 20 64 62 64 61 74 cfg dbname dbdat
a540: 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 23 74 0a ).;;; ;; #t.
a550: 3b 3b 3b 20 3b 3b 20 20 20 20 20 29 29 0a 3b 3b ;;; ;; )).;;
a560: 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ; .;;; (define (
a570: 66 69 6e 61 6c 69 7a 65 2d 61 6c 6c 2d 64 62 2d finalize-all-db-
a580: 68 61 6e 64 6c 65 73 20 61 63 66 67 29 0a 3b 3b handles acfg).;;
a590: 3b 20 20 20 28 6c 65 74 2a 20 28 28 64 62 68 61 ; (let* ((dbha
a5a0: 6e 64 6c 65 73 20 28 61 72 65 61 2d 64 62 68 61 ndles (area-dbha
a5b0: 6e 64 6c 65 73 20 61 63 66 67 29 29 20 20 3b 3b ndles acfg)) ;;
a5c0: 20 64 62 68 61 6e 64 6c 65 73 20 69 73 20 68 61 dbhandles is ha
a5d0: 73 68 20 6f 66 20 66 6e 61 6d 65 20 3d 3d 3e 20 sh of fname ==>
a5e0: 64 62 64 61 74 0a 3b 3b 3b 20 09 20 28 6e 75 6d dbdat.;;; . (num
a5f0: 20 20 20 20 20 20 20 30 29 29 0a 3b 3b 3b 20 20 0)).;;;
a600: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b (for-each.;;;
a610: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 (lambda (a
a620: 72 65 61 2d 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 rea-name).;;;
a630: 20 20 20 20 20 28 70 72 69 6e 74 20 22 43 6c 6f (print "Clo
a640: 73 69 6e 67 20 68 61 6e 64 6c 65 73 20 66 6f 72 sing handles for
a650: 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 3b 3b " area-name).;;
a660: 3b 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 ; (let ((
a670: 64 62 64 61 74 73 20 28 68 61 73 68 2d 74 61 62 dbdats (hash-tab
a680: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 64 le-ref/default d
a690: 62 68 61 6e 64 6c 65 73 20 61 72 65 61 2d 6e 61 bhandles area-na
a6a0: 6d 65 20 27 28 29 29 29 29 0a 3b 3b 3b 20 09 20 me '()))).;;; .
a6b0: 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 09 20 (for-each.;;; .
a6c0: 20 28 6c 61 6d 62 64 61 20 28 64 62 64 61 74 29 (lambda (dbdat)
a6d0: 0a 3b 3b 3b 20 09 20 20 20 20 3b 3b 20 66 69 72 .;;; . ;; fir
a6e0: 73 74 20 63 6c 6f 73 65 20 61 6c 6c 20 73 74 61 st close all sta
a6f0: 74 65 6d 65 6e 74 20 68 61 6e 64 6c 65 73 0a 3b tement handles.;
a700: 3b 3b 20 09 20 20 20 20 28 66 6f 72 2d 65 61 63 ;; . (for-eac
a710: 68 0a 3b 3b 3b 20 09 20 20 20 20 20 28 6c 61 6d h.;;; . (lam
a720: 62 64 61 20 28 73 74 68 29 0a 3b 3b 3b 20 09 20 bda (sth).;;; .
a730: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 (sqlite3:f
a740: 69 6e 61 6c 69 7a 65 21 20 73 74 68 29 0a 3b 3b inalize! sth).;;
a750: 3b 20 09 20 20 20 20 20 20 20 28 73 65 74 21 20 ; . (set!
a760: 6e 75 6d 20 28 2b 20 6e 75 6d 20 31 29 29 29 0a num (+ num 1))).
a770: 3b 3b 3b 20 09 20 20 20 20 20 28 68 61 73 68 2d ;;; . (hash-
a780: 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 28 64 62 table-values (db
a790: 64 61 74 2d 73 74 68 73 20 64 62 64 61 74 29 29 dat-sths dbdat))
a7a0: 29 0a 3b 3b 3b 20 09 20 20 20 20 3b 3b 20 6e 6f ).;;; . ;; no
a7b0: 77 20 63 6c 6f 73 65 20 74 68 65 20 64 62 68 0a w close the dbh.
a7c0: 3b 3b 3b 20 09 20 20 20 20 28 73 65 74 21 20 6e ;;; . (set! n
a7d0: 75 6d 20 28 2b 20 6e 75 6d 20 31 29 29 0a 3b 3b um (+ num 1)).;;
a7e0: 3b 20 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a ; . (sqlite3:
a7f0: 66 69 6e 61 6c 69 7a 65 21 20 28 64 62 64 61 74 finalize! (dbdat
a800: 2d 64 62 68 20 64 62 64 61 74 29 29 29 0a 3b 3b -dbh dbdat))).;;
a810: 3b 20 09 20 20 64 62 64 61 74 73 29 29 29 0a 3b ; . dbdats))).;
a820: 3b 3b 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 ;; (hash-ta
a830: 62 6c 65 2d 6b 65 79 73 20 64 62 68 61 6e 64 6c ble-keys dbhandl
a840: 65 73 29 29 0a 3b 3b 3b 20 20 20 20 20 28 70 72 es)).;;; (pr
a850: 69 6e 74 20 22 46 49 4e 41 4c 49 5a 45 44 20 22 int "FINALIZED "
a860: 20 6e 75 6d 20 22 20 64 62 68 61 6e 64 6c 65 73 num " dbhandles
a870: 22 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b "))).;;; .;;; ;;
a880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8c0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 57 20 ======.;;; ;; W
a8d0: 4f 20 52 20 4b 20 20 20 51 20 55 20 45 20 55 20 O R K Q U E U
a8e0: 45 20 20 20 48 20 41 20 4e 20 44 20 4c 20 49 20 E H A N D L I
a8f0: 4e 20 47 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d N G .;;; ;;=====
a900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a940: 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 =.;;; .;;; (defi
a950: 6e 65 20 28 72 65 67 69 73 74 65 72 2d 64 62 2d ne (register-db-
a960: 61 73 2d 6d 69 6e 65 20 61 63 66 67 20 64 62 6e as-mine acfg dbn
a970: 61 6d 65 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 ame).;;; (let
a980: 28 28 68 74 20 28 61 72 65 61 2d 64 62 73 20 61 ((ht (area-dbs a
a990: 63 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 cfg))).;;; (
a9a0: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
a9b0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
a9c0: 68 74 20 64 62 6e 61 6d 65 20 23 66 29 29 0a 3b ht dbname #f)).;
a9d0: 3b 3b 20 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ;; .(hash-table-
a9e0: 73 65 74 21 20 68 74 20 64 62 6e 61 6d 65 20 28 set! ht dbname (
a9f0: 72 61 6e 64 6f 6d 20 31 30 30 30 30 29 29 29 29 random 10000))))
aa00: 29 0a 3b 3b 3b 20 09 0a 3b 3b 3b 20 28 64 65 66 ).;;; ..;;; (def
aa10: 69 6e 65 20 28 77 6f 72 6b 2d 71 75 65 75 65 2d ine (work-queue-
aa20: 61 64 64 20 61 63 66 67 20 66 6e 61 6d 65 20 77 add acfg fname w
aa30: 69 74 65 6d 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 item).;;; (let
aa40: 2a 20 28 28 77 6f 72 6b 2d 71 75 65 75 65 2d 73 * ((work-queue-s
aa50: 74 61 72 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 tart (current-mi
aa60: 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b lliseconds)).;;;
aa70: 20 09 20 28 61 63 74 69 6f 6e 20 20 20 20 20 20 . (action
aa80: 20 20 20 20 20 28 77 69 74 65 6d 2d 61 63 74 69 (witem-acti
aa90: 6f 6e 20 77 69 74 65 6d 29 29 20 3b 3b 20 4e 42 on witem)) ;; NB
aaa0: 20 74 68 65 20 61 63 74 69 6f 6e 20 69 73 20 74 the action is t
aab0: 68 65 20 69 6e 64 65 78 20 69 6e 74 6f 20 74 68 he index into th
aac0: 65 20 72 64 61 74 20 61 63 74 69 6f 6e 73 0a 3b e rdat actions.;
aad0: 3b 3b 20 09 20 28 71 64 61 74 20 20 20 20 20 20 ;; . (qdat
aae0: 20 20 20 20 20 20 20 28 6f 72 20 28 68 61 73 68 (or (hash
aaf0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
ab00: 6c 74 20 28 61 72 65 61 2d 77 71 75 65 75 65 73 lt (area-wqueues
ab10: 20 61 63 66 67 29 20 66 6e 61 6d 65 20 23 66 29 acfg) fname #f)
ab20: 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 20 28 .;;; ... (
ab30: 6c 65 74 20 28 28 6e 65 77 71 64 61 74 20 28 6d let ((newqdat (m
ab40: 61 6b 65 2d 71 64 61 74 29 29 29 0a 3b 3b 3b 20 ake-qdat))).;;;
ab50: 09 09 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 .... (hash-table
ab60: 2d 73 65 74 21 20 28 61 72 65 61 2d 77 71 75 65 -set! (area-wque
ab70: 75 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 20 ues acfg) fname
ab80: 6e 65 77 71 64 61 74 29 0a 3b 3b 3b 20 09 09 09 newqdat).;;; ...
ab90: 09 20 6e 65 77 71 64 61 74 29 29 29 0a 3b 3b 3b . newqdat))).;;;
aba0: 20 09 20 28 72 64 61 74 20 20 20 20 20 20 20 20 . (rdat
abb0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
abc0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 61 72 -ref/default (ar
abd0: 65 61 2d 72 74 61 62 6c 65 20 61 63 66 67 29 20 ea-rtable acfg)
abe0: 61 63 74 69 6f 6e 20 23 66 29 29 29 0a 3b 3b 3b action #f))).;;;
abf0: 20 20 20 20 20 28 69 66 20 72 64 61 74 0a 3b 3b (if rdat.;;
ac00: 3b 20 09 28 71 75 65 75 65 2d 61 64 64 21 0a 3b ; .(queue-add!.;
ac10: 3b 3b 20 09 20 28 63 61 73 65 20 28 63 61 6c 6c ;; . (case (call
ac20: 64 61 74 2d 63 74 79 70 65 20 72 64 61 74 29 0a dat-ctype rdat).
ac30: 3b 3b 3b 20 09 20 20 20 28 28 64 62 77 72 69 74 ;;; . ((dbwrit
ac40: 65 29 20 20 20 28 72 65 67 69 73 74 65 72 2d 64 e) (register-d
ac50: 62 2d 61 73 2d 6d 69 6e 65 20 61 63 66 67 20 66 b-as-mine acfg f
ac60: 6e 61 6d 65 29 28 71 64 61 74 2d 77 72 69 74 65 name)(qdat-write
ac70: 71 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 20 20 q qdat)).;;; .
ac80: 20 28 28 64 62 72 65 61 64 29 20 20 20 20 28 72 ((dbread) (r
ac90: 65 67 69 73 74 65 72 2d 64 62 2d 61 73 2d 6d 69 egister-db-as-mi
aca0: 6e 65 20 61 63 66 67 20 66 6e 61 6d 65 29 28 71 ne acfg fname)(q
acb0: 64 61 74 2d 72 65 61 64 71 20 20 71 64 61 74 29 dat-readq qdat)
acc0: 29 0a 3b 3b 3b 20 09 20 20 20 28 28 64 62 72 77 ).;;; . ((dbrw
acd0: 29 20 20 20 20 20 20 28 72 65 67 69 73 74 65 72 ) (register
ace0: 2d 64 62 2d 61 73 2d 6d 69 6e 65 20 61 63 66 67 -db-as-mine acfg
acf0: 20 66 6e 61 6d 65 29 28 71 64 61 74 2d 72 77 71 fname)(qdat-rwq
ad00: 20 20 20 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 qdat)).;;; .
ad10: 20 20 20 28 28 6f 73 6c 6f 6e 67 29 20 20 20 20 ((oslong)
ad20: 28 71 64 61 74 2d 6f 73 6c 6f 6e 67 20 71 64 61 (qdat-oslong qda
ad30: 74 29 29 0a 3b 3b 3b 20 09 20 20 20 28 28 6f 73 t)).;;; . ((os
ad40: 73 68 6f 72 74 29 20 20 20 28 71 64 61 74 2d 6f short) (qdat-o
ad50: 73 73 68 6f 72 74 20 71 64 61 74 29 29 0a 3b 3b sshort qdat)).;;
ad60: 3b 20 09 20 20 20 28 28 66 75 6c 6c 2d 70 69 6e ; . ((full-pin
ad70: 67 29 20 28 71 64 61 74 2d 6d 69 73 63 20 20 71 g) (qdat-misc q
ad80: 64 61 74 29 29 0a 3b 3b 3b 20 09 20 20 20 28 65 dat)).;;; . (e
ad90: 6c 73 65 0a 3b 3b 3b 20 09 20 20 20 20 28 70 72 lse.;;; . (pr
ada0: 69 6e 74 20 22 45 52 52 4f 52 3a 20 6e 6f 20 71 int "ERROR: no q
adb0: 75 65 75 65 20 66 6f 72 20 22 20 61 63 74 69 6f ueue for " actio
adc0: 6e 20 22 2e 20 41 64 64 69 6e 67 20 74 6f 20 64 n ". Adding to d
add0: 62 77 72 69 74 65 20 71 75 65 75 65 2e 22 29 0a bwrite queue.").
ade0: 3b 3b 3b 20 09 20 20 20 20 28 71 64 61 74 2d 77 ;;; . (qdat-w
adf0: 72 69 74 65 71 20 71 64 61 74 29 29 29 0a 3b 3b riteq qdat))).;;
ae00: 3b 20 09 20 77 69 74 65 6d 29 0a 3b 3b 3b 20 09 ; . witem).;;; .
ae10: 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 3b 3b 3b (case action.;;;
ae20: 20 09 20 20 28 28 66 75 6c 6c 2d 70 69 6e 67 29 . ((full-ping)
ae30: 28 71 64 61 74 2d 6d 69 73 63 20 71 64 61 74 29 (qdat-misc qdat)
ae40: 29 0a 3b 3b 3b 20 09 20 20 28 65 6c 73 65 0a 3b ).;;; . (else.;
ae50: 3b 3b 20 09 20 20 20 28 70 72 69 6e 74 20 22 45 ;; . (print "E
ae60: 52 52 4f 52 3a 20 4e 6f 20 61 63 74 69 6f 6e 20 RROR: No action
ae70: 22 20 61 63 74 69 6f 6e 20 22 20 77 61 73 20 72 " action " was r
ae80: 65 67 69 73 74 65 72 65 64 22 29 29 29 29 0a 3b egistered")))).;
ae90: 3b 3b 20 20 20 20 20 28 73 64 62 67 3e 20 22 77 ;; (sdbg> "w
aea0: 6f 72 6b 2d 71 75 65 75 65 2d 61 64 64 22 20 22 ork-queue-add" "
aeb0: 71 75 65 75 65 2d 61 64 64 22 20 77 6f 72 6b 2d queue-add" work-
aec0: 71 75 65 75 65 2d 73 74 61 72 74 20 23 66 20 23 queue-start #f #
aed0: 66 29 0a 3b 3b 3b 20 20 20 20 20 23 74 29 29 20 f).;;; #t))
aee0: 3b 3b 20 66 6f 72 20 6e 6f 77 2c 20 73 69 6d 70 ;; for now, simp
aef0: 6c 79 20 72 65 74 75 72 6e 20 23 74 20 74 6f 20 ly return #t to
af00: 69 6e 64 69 63 61 74 65 20 72 65 71 75 65 73 74 indicate request
af10: 20 67 6f 74 20 74 6f 20 74 68 65 20 71 75 65 75 got to the queu
af20: 65 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 e.;;; .;;; (defi
af30: 6e 65 20 28 64 6f 71 75 65 75 65 20 61 63 66 67 ne (doqueue acfg
af40: 20 71 20 66 6e 61 6d 65 20 64 62 64 61 74 20 64 q fname dbdat d
af50: 62 68 29 0a 3b 3b 3b 20 20 20 3b 3b 20 28 70 72 bh).;;; ;; (pr
af60: 69 6e 74 20 22 64 6f 71 75 65 75 65 3a 20 22 20 int "doqueue: "
af70: 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 28 6c 65 fname).;;; (le
af80: 74 2a 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 t* ((start-time
af90: 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 (current-millise
afa0: 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 28 71 conds)).;;; . (q
afb0: 6c 65 6e 20 20 20 20 20 20 20 28 71 75 65 75 65 len (queue
afc0: 2d 6c 65 6e 67 74 68 20 71 29 29 29 0a 3b 3b 3b -length q))).;;;
afd0: 20 20 20 20 20 28 69 66 20 28 3e 20 71 6c 65 6e (if (> qlen
afe0: 20 31 29 0a 3b 3b 3b 20 09 28 70 72 69 6e 74 20 1).;;; .(print
aff0: 22 50 72 6f 63 65 73 73 69 6e 67 20 71 75 65 75 "Processing queu
b000: 65 20 6f 66 20 6c 65 6e 67 74 68 20 22 20 71 6c e of length " ql
b010: 65 6e 29 29 0a 3b 3b 3b 20 20 20 20 20 28 6c 65 en)).;;; (le
b020: 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 t loop ((count
b030: 20 20 20 20 30 29 0a 3b 3b 3b 20 09 20 20 20 20 0).;;; .
b040: 20 20 20 28 72 65 73 70 6f 6e 73 65 73 20 27 28 (responses '(
b050: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 6c ))).;;; (l
b060: 65 74 20 28 28 64 65 6c 74 61 20 28 2d 20 28 63 et ((delta (- (c
b070: 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
b080: 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 nds) start-time)
b090: 29 29 0a 3b 3b 3b 20 09 28 69 66 20 28 6f 72 20 )).;;; .(if (or
b0a0: 28 71 75 65 75 65 2d 65 6d 70 74 79 3f 20 71 29 (queue-empty? q)
b0b0: 0a 3b 3b 3b 20 09 09 28 3e 20 64 65 6c 74 61 20 .;;; ..(> delta
b0c0: 34 30 30 29 29 20 3b 3b 20 73 74 6f 70 20 77 6f 400)) ;; stop wo
b0d0: 72 6b 69 6e 67 20 6f 6e 20 74 68 69 73 20 71 75 rking on this qu
b0e0: 65 75 65 20 61 66 74 65 72 20 34 30 30 6d 73 20 eue after 400ms
b0f0: 68 61 76 65 20 70 61 73 73 65 64 0a 3b 3b 3b 20 have passed.;;;
b100: 09 20 20 20 20 28 6c 69 73 74 20 63 6f 75 6e 74 . (list count
b110: 20 64 65 6c 74 61 20 72 65 73 70 6f 6e 73 65 73 delta responses
b120: 29 20 3b 3b 20 72 65 74 75 72 6e 20 63 6f 75 6e ) ;; return coun
b130: 74 2c 20 64 65 6c 74 61 20 61 6e 64 20 72 65 73 t, delta and res
b140: 70 6f 6e 73 65 73 20 6c 69 73 74 0a 3b 3b 3b 20 ponses list.;;;
b150: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 77 69 74 . (let* ((wit
b160: 65 6d 20 20 28 71 75 65 75 65 2d 72 65 6d 6f 76 em (queue-remov
b170: 65 21 20 71 29 29 0a 3b 3b 3b 20 09 09 20 20 20 e! q)).;;; ..
b180: 28 61 63 74 69 6f 6e 20 28 77 69 74 65 6d 2d 61 (action (witem-a
b190: 63 74 69 6f 6e 20 77 69 74 65 6d 29 29 0a 3b 3b ction witem)).;;
b1a0: 3b 20 09 09 20 20 20 28 72 64 61 74 20 20 20 28 ; .. (rdat (
b1b0: 77 69 74 65 6d 2d 72 64 61 74 20 20 20 77 69 74 witem-rdat wit
b1c0: 65 6d 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 73 em)).;;; .. (s
b1d0: 74 6d 74 20 20 20 28 63 61 6c 6c 64 61 74 2d 6f tmt (calldat-o
b1e0: 62 6a 20 72 64 61 74 29 29 0a 3b 3b 3b 20 09 09 bj rdat)).;;; ..
b1f0: 20 20 20 28 73 74 68 20 20 20 20 28 66 75 6c 6c (sth (full
b200: 2d 67 65 74 2d 73 74 68 20 61 63 66 67 20 66 6e -get-sth acfg fn
b210: 61 6d 65 20 73 74 6d 74 29 29 0a 3b 3b 3b 20 09 ame stmt)).;;; .
b220: 09 20 20 20 28 63 74 79 70 65 20 20 28 63 61 6c . (ctype (cal
b230: 6c 64 61 74 2d 63 74 79 70 65 20 72 64 61 74 29 ldat-ctype rdat)
b240: 29 0a 3b 3b 3b 20 09 09 20 20 20 28 64 61 74 61 ).;;; .. (data
b250: 20 20 20 28 77 69 74 65 6d 2d 64 61 74 61 20 20 (witem-data
b260: 20 77 69 74 65 6d 29 29 0a 3b 3b 3b 20 09 09 20 witem)).;;; ..
b270: 20 20 28 63 6f 6f 6b 69 65 20 28 77 69 74 65 6d (cookie (witem
b280: 2d 63 6f 6f 6b 69 65 20 77 69 74 65 6d 29 29 29 -cookie witem)))
b290: 0a 3b 3b 3b 20 09 20 20 20 20 20 20 3b 3b 20 64 .;;; . ;; d
b2a0: 6f 20 74 68 65 20 70 72 6f 63 65 73 73 69 6e 67 o the processing
b2b0: 20 61 6e 64 20 73 61 76 65 20 74 68 65 20 72 65 and save the re
b2c0: 73 75 6c 74 20 69 6e 20 77 69 74 65 6d 2d 72 65 sult in witem-re
b2d0: 73 75 6c 74 0a 3b 3b 3b 20 09 20 20 20 20 20 20 sult.;;; .
b2e0: 28 77 69 74 65 6d 2d 72 65 73 75 6c 74 2d 73 65 (witem-result-se
b2f0: 74 21 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 77 t!.;;; . w
b300: 69 74 65 6d 0a 3b 3b 3b 20 09 20 20 20 20 20 20 item.;;; .
b310: 20 28 63 61 73 65 20 63 74 79 70 65 20 3b 3b 20 (case ctype ;;
b320: 61 63 74 69 6f 6e 0a 3b 3b 3b 20 09 09 20 28 28 action.;;; .. ((
b330: 6e 6f 62 6c 6f 63 6b 77 72 69 74 65 29 20 3b 3b noblockwrite) ;;
b340: 20 62 6c 69 6e 64 20 77 72 69 74 65 2c 20 6e 6f blind write, no
b350: 20 61 63 6b 20 6f 66 20 73 75 63 63 65 73 73 20 ack of success
b360: 72 65 74 75 72 6e 65 64 0a 3b 3b 3b 20 09 09 20 returned.;;; ..
b370: 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a (apply sqlite3:
b380: 65 78 65 63 75 74 65 20 73 74 68 20 64 61 74 61 execute sth data
b390: 29 0a 3b 3b 3b 20 09 09 20 20 28 73 71 6c 69 74 ).;;; .. (sqlit
b3a0: 65 33 3a 6c 61 73 74 2d 69 6e 73 65 72 74 2d 72 e3:last-insert-r
b3b0: 6f 77 69 64 20 64 62 68 29 29 0a 3b 3b 3b 20 09 owid dbh)).;;; .
b3c0: 09 20 28 28 64 62 77 72 69 74 65 29 20 20 20 20 . ((dbwrite)
b3d0: 20 20 3b 3b 20 62 6c 6f 63 6b 69 6e 67 20 77 72 ;; blocking wr
b3e0: 69 74 65 20 20 20 0a 3b 3b 3b 20 09 09 20 20 28 ite .;;; .. (
b3f0: 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 apply sqlite3:ex
b400: 65 63 75 74 65 20 73 74 68 20 64 61 74 61 29 0a ecute sth data).
b410: 3b 3b 3b 20 09 09 20 20 23 74 29 0a 3b 3b 3b 20 ;;; .. #t).;;;
b420: 09 09 20 28 28 64 62 72 65 61 64 29 20 3b 3b 20 .. ((dbread) ;;
b430: 54 4f 44 4f 3a 20 63 6f 6e 73 69 64 65 72 20 62 TODO: consider b
b440: 72 65 61 6b 69 6e 67 20 74 68 69 73 20 75 70 20 reaking this up
b450: 61 6e 64 20 73 68 69 70 70 69 6e 67 20 69 6e 20 and shipping in
b460: 70 69 65 63 65 73 20 66 6f 72 20 6c 61 72 67 65 pieces for large
b470: 20 71 75 65 72 79 0a 3b 3b 3b 20 09 09 20 20 28 query.;;; .. (
b480: 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 6d 61 apply sqlite3:ma
b490: 70 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 78 20 p-row (lambda x
b4a0: 78 29 20 73 74 68 20 64 61 74 61 29 29 0a 3b 3b x) sth data)).;;
b4b0: 3b 20 09 09 20 28 28 66 75 6c 6c 2d 70 69 6e 67 ; .. ((full-ping
b4c0: 29 20 20 27 66 75 6c 6c 2d 70 69 6e 67 29 0a 3b ) 'full-ping).;
b4d0: 3b 3b 20 09 09 20 28 65 6c 73 65 20 28 70 72 69 ;; .. (else (pri
b4e0: 6e 74 20 22 4e 6f 74 20 72 65 61 64 79 20 66 6f nt "Not ready fo
b4f0: 72 20 61 63 74 69 6f 6e 20 22 20 61 63 74 69 6f r action " actio
b500: 6e 29 20 23 66 29 29 29 0a 3b 3b 3b 20 09 20 20 n) #f))).;;; .
b510: 20 20 20 20 28 6c 6f 6f 70 20 28 61 64 64 31 20 (loop (add1
b520: 63 6f 75 6e 74 29 0a 3b 3b 3b 20 09 09 20 20 20 count).;;; ..
b530: 20 28 69 66 20 63 6f 6f 6b 69 65 0a 3b 3b 3b 20 (if cookie.;;;
b540: 09 09 09 28 63 6f 6e 73 20 77 69 74 65 6d 20 72 ...(cons witem r
b550: 65 73 70 6f 6e 73 65 73 29 0a 3b 3b 3b 20 09 09 esponses).;;; ..
b560: 09 72 65 73 70 6f 6e 73 65 73 29 29 29 29 29 29 .responses))))))
b570: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 64 )).;;; .;;; ;; d
b580: 6f 20 75 70 20 74 6f 20 34 30 30 6d 73 20 6f 66 o up to 400ms of
b590: 20 70 72 6f 63 65 73 73 69 6e 67 20 6f 6e 20 65 processing on e
b5a0: 61 63 68 20 71 75 65 75 65 0a 3b 3b 3b 20 3b 3b ach queue.;;; ;;
b5b0: 20 2d 20 74 68 65 20 77 6f 72 6b 2d 71 75 65 75 - the work-queu
b5c0: 65 2d 70 72 6f 63 65 73 73 6f 72 20 77 69 6c 6c e-processor will
b5d0: 20 61 6c 6c 6f 77 20 74 68 65 20 6d 61 78 20 31 allow the max 1
b5e0: 32 30 30 6d 73 20 6f 66 20 77 6f 72 6b 20 74 6f 200ms of work to
b5f0: 20 63 6f 6d 70 6c 65 74 65 20 62 75 74 20 69 74 complete but it
b600: 20 77 69 6c 6c 20 66 6c 61 67 20 61 73 20 6f 76 will flag as ov
b610: 65 72 6c 6f 61 64 65 64 0a 3b 3b 3b 20 3b 3b 20 erloaded.;;; ;;
b620: 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 70 72 .;;; (define (pr
b630: 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 69 65 73 ocess-db-queries
b640: 20 61 63 66 67 20 66 6e 61 6d 65 29 0a 3b 3b 3b acfg fname).;;;
b650: 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 (if (hash-tab
b660: 6c 65 2d 65 78 69 73 74 73 3f 20 28 61 72 65 61 le-exists? (area
b670: 2d 77 71 75 65 75 65 73 20 61 63 66 67 29 20 66 -wqueues acfg) f
b680: 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 20 20 20 20 name).;;;
b690: 28 6c 65 74 2a 20 28 28 70 72 6f 63 65 73 73 2d (let* ((process-
b6a0: 64 62 2d 71 75 65 72 69 65 73 2d 73 74 61 72 74 db-queries-start
b6b0: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d -time (current-m
b6c0: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b 3b illiseconds)).;;
b6d0: 3b 20 09 20 20 20 20 20 28 71 64 61 74 20 20 20 ; . (qdat
b6e0: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
b6f0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
b700: 74 20 28 61 72 65 61 2d 77 71 75 65 75 65 73 20 t (area-wqueues
b710: 61 63 66 67 29 20 66 6e 61 6d 65 20 23 66 29 29 acfg) fname #f))
b720: 0a 3b 3b 3b 20 09 20 20 20 20 20 28 71 75 65 75 .;;; . (queu
b730: 65 2d 73 79 6d 2d 3e 71 75 65 75 65 20 28 6c 61 e-sym->queue (la
b740: 6d 62 64 61 20 28 71 75 65 75 65 2d 73 79 6d 29 mbda (queue-sym)
b750: 0a 3b 3b 3b 20 09 09 09 09 20 28 63 61 73 65 20 .;;; .... (case
b760: 71 75 65 75 65 2d 73 79 6d 20 20 3b 3b 20 6c 6f queue-sym ;; lo
b770: 6f 6b 75 70 20 74 68 65 20 71 75 65 75 65 20 66 okup the queue f
b780: 72 6f 6d 20 71 64 61 74 20 67 69 76 65 6e 20 61 rom qdat given a
b790: 20 6e 61 6d 65 20 28 73 79 6d 62 6f 6c 29 0a 3b name (symbol).;
b7a0: 3b 3b 20 09 09 09 09 20 20 20 28 28 77 71 75 65 ;; .... ((wque
b7b0: 75 65 29 20 20 28 71 64 61 74 2d 77 72 69 74 65 ue) (qdat-write
b7c0: 71 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 09 09 q qdat)).;;; ...
b7d0: 09 20 20 20 28 28 72 71 75 65 75 65 29 20 20 28 . ((rqueue) (
b7e0: 71 64 61 74 2d 72 65 61 64 71 20 20 71 64 61 74 qdat-readq qdat
b7f0: 29 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 28 28 )).;;; .... ((
b800: 72 77 71 75 65 75 65 29 20 28 71 64 61 74 2d 72 rwqueue) (qdat-r
b810: 77 71 20 20 20 20 71 64 61 74 29 29 0a 3b 3b 3b wq qdat)).;;;
b820: 20 09 09 09 09 20 20 20 28 28 6d 69 73 63 29 20 .... ((misc)
b830: 20 20 20 28 71 64 61 74 2d 6d 69 73 63 20 20 20 (qdat-misc
b840: 71 64 61 74 29 29 0a 3b 3b 3b 20 09 09 09 09 20 qdat)).;;; ....
b850: 20 20 28 65 6c 73 65 20 23 66 29 29 29 29 0a 3b (else #f)))).;
b860: 3b 3b 20 09 20 20 20 20 20 28 64 62 64 61 74 20 ;; . (dbdat
b870: 20 20 28 67 65 74 2d 64 62 68 20 61 63 66 67 20 (get-dbh acfg
b880: 66 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 20 20 fname)).;;; .
b890: 20 20 28 64 62 68 20 20 20 20 20 28 69 66 20 28 (dbh (if (
b8a0: 64 62 64 61 74 3f 20 64 62 64 61 74 29 28 64 62 dbdat? dbdat)(db
b8b0: 64 61 74 2d 64 62 68 20 64 62 64 61 74 29 20 23 dat-dbh dbdat) #
b8c0: 66 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 28 6e f)).;;; . (n
b8d0: 6f 77 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d owtime (current-
b8e0: 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 09 seconds))).;;; .
b8f0: 3b 3b 20 68 61 6e 64 6c 65 20 74 68 65 20 71 75 ;; handle the qu
b900: 65 75 65 73 20 74 68 61 74 20 72 65 71 75 69 72 eues that requir
b910: 65 20 61 20 74 72 61 6e 73 61 63 74 69 6f 6e 0a e a transaction.
b920: 3b 3b 3b 20 09 3b 3b 0a 3b 3b 3b 20 09 28 6d 61 ;;; .;;.;;; .(ma
b930: 70 20 3b 3b 20 0a 3b 3b 3b 20 09 20 28 6c 61 6d p ;; .;;; . (lam
b940: 62 64 61 20 28 71 75 65 75 65 2d 73 79 6d 29 0a bda (queue-sym).
b950: 3b 3b 3b 20 09 20 20 20 3b 3b 20 28 70 72 69 6e ;;; . ;; (prin
b960: 74 20 22 70 72 6f 63 65 73 73 69 6e 67 20 71 75 t "processing qu
b970: 65 75 65 20 22 20 71 75 65 75 65 2d 73 79 6d 29 eue " queue-sym)
b980: 0a 3b 3b 3b 20 09 20 20 20 28 6c 65 74 2a 20 28 .;;; . (let* (
b990: 28 71 75 65 75 65 20 28 71 75 65 75 65 2d 73 79 (queue (queue-sy
b9a0: 6d 2d 3e 71 75 65 75 65 20 71 75 65 75 65 2d 73 m->queue queue-s
b9b0: 79 6d 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 ym))).;;; .
b9c0: 28 69 66 20 28 6e 6f 74 20 28 71 75 65 75 65 2d (if (not (queue-
b9d0: 65 6d 70 74 79 3f 20 71 75 65 75 65 29 29 0a 3b empty? queue)).;
b9e0: 3b 3b 20 09 09 20 28 6c 65 74 20 28 28 72 65 73 ;; .. (let ((res
b9f0: 70 6f 6e 73 65 73 0a 3b 3b 3b 20 09 09 09 28 73 ponses.;;; ...(s
ba00: 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 61 6e qlite3:with-tran
ba10: 73 61 63 74 69 6f 6e 20 3b 3b 20 74 6f 64 6f 20 saction ;; todo
ba20: 2d 20 63 61 74 63 68 20 65 78 63 65 70 74 69 6f - catch exceptio
ba30: 6e 73 2e 2e 2e 0a 3b 3b 3b 20 09 09 09 20 64 62 ns....;;; ... db
ba40: 68 0a 3b 3b 3b 20 09 09 09 20 28 6c 61 6d 62 64 h.;;; ... (lambd
ba50: 61 20 28 29 0a 3b 3b 3b 20 09 09 09 20 20 20 28 a ().;;; ... (
ba60: 6c 65 74 2a 20 28 28 72 65 73 20 28 64 6f 71 75 let* ((res (doqu
ba70: 65 75 65 20 61 63 66 67 20 71 75 65 75 65 20 66 eue acfg queue f
ba80: 6e 61 6d 65 20 64 62 64 61 74 20 64 62 68 29 29 name dbdat dbh))
ba90: 29 20 3b 3b 20 74 68 69 73 20 64 6f 65 73 20 74 ) ;; this does t
baa0: 68 65 20 77 6f 72 6b 21 0a 3b 3b 3b 20 09 09 09 he work!.;;; ...
bab0: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
bac0: 72 65 73 3d 22 20 72 65 73 29 0a 3b 3b 3b 20 09 res=" res).;;; .
bad0: 09 09 20 20 20 20 20 28 6d 61 74 63 68 20 72 65 .. (match re
bae0: 73 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 28 s.;;; ... (
baf0: 28 63 6f 75 6e 74 20 64 65 6c 74 61 20 72 65 73 (count delta res
bb00: 70 6f 6e 73 65 73 29 0a 3b 3b 3b 20 09 09 09 20 ponses).;;; ...
bb10: 20 20 20 20 20 20 28 75 70 64 61 74 65 2d 73 74 (update-st
bb20: 61 74 73 20 61 63 66 67 20 66 6e 61 6d 65 20 71 ats acfg fname q
bb30: 75 65 75 65 2d 73 79 6d 20 64 65 6c 74 61 20 63 ueue-sym delta c
bb40: 6f 75 6e 74 29 0a 3b 3b 3b 20 09 09 09 20 20 20 ount).;;; ...
bb50: 20 20 20 20 28 73 64 62 67 3e 20 22 70 72 6f 63 (sdbg> "proc
bb60: 65 73 73 2d 64 62 2d 71 75 65 72 69 65 73 22 20 ess-db-queries"
bb70: 22 73 71 6c 69 74 65 33 2d 74 72 61 6e 73 61 63 "sqlite3-transac
bb80: 74 69 6f 6e 22 20 70 72 6f 63 65 73 73 2d 64 62 tion" process-db
bb90: 2d 71 75 65 72 69 65 73 2d 73 74 61 72 74 2d 74 -queries-start-t
bba0: 69 6d 65 20 23 66 20 23 66 29 0a 3b 3b 3b 20 09 ime #f #f).;;; .
bbb0: 09 09 20 20 20 20 20 20 20 72 65 73 70 6f 6e 73 .. respons
bbc0: 65 73 29 20 3b 3b 20 72 65 74 75 72 6e 20 72 65 es) ;; return re
bbd0: 73 70 6f 6e 73 65 73 0a 3b 3b 3b 20 09 09 09 20 sponses.;;; ...
bbe0: 20 20 20 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 (else.;;; .
bbf0: 09 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 .. (print
bc00: 22 45 52 52 4f 52 3a 20 62 61 64 20 72 65 74 75 "ERROR: bad retu
bc10: 72 6e 20 64 61 74 61 20 66 72 6f 6d 20 64 6f 71 rn data from doq
bc20: 75 65 75 65 20 22 20 72 65 73 29 29 29 0a 3b 3b ueue " res))).;;
bc30: 3b 20 09 09 09 20 20 20 20 20 29 29 29 29 29 0a ; ... ))))).
bc40: 3b 3b 3b 20 09 09 20 20 20 3b 3b 20 68 61 76 69 ;;; .. ;; havi
bc50: 6e 67 20 63 6f 6d 70 6c 65 74 65 64 20 74 68 65 ng completed the
bc60: 20 74 72 61 6e 73 61 63 74 69 6f 6e 2c 20 73 65 transaction, se
bc70: 6e 64 20 74 68 65 20 72 65 73 70 6f 6e 73 65 73 nd the responses
bc80: 2e 0a 3b 3b 3b 20 09 09 20 20 20 3b 3b 20 28 70 ..;;; .. ;; (p
bc90: 72 69 6e 74 20 22 49 4e 46 4f 3a 20 73 65 6e 64 rint "INFO: send
bca0: 69 6e 67 20 22 20 28 6c 65 6e 67 74 68 20 72 65 ing " (length re
bcb0: 73 70 6f 6e 73 65 73 29 20 22 20 72 65 73 70 6f sponses) " respo
bcc0: 6e 73 65 73 2e 22 29 0a 3b 3b 3b 20 09 09 20 20 nses.").;;; ..
bcd0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 65 73 (let loop ((res
bce0: 70 6f 6e 73 65 73 2d 6c 65 66 74 20 72 65 73 70 ponses-left resp
bcf0: 6f 6e 73 65 73 29 29 0a 3b 3b 3b 20 09 09 20 20 onses)).;;; ..
bd00: 20 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 09 09 20 (cond.;;; ..
bd10: 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 72 65 73 ((null? res
bd20: 70 6f 6e 73 65 73 2d 6c 65 66 74 29 20 20 23 74 ponses-left) #t
bd30: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 28 65 ).;;; .. (e
bd40: 6c 73 65 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 lse.;;; ..
bd50: 20 28 6c 65 74 2a 20 28 28 77 69 74 65 6d 20 20 (let* ((witem
bd60: 20 20 28 63 61 72 20 72 65 73 70 6f 6e 73 65 73 (car responses
bd70: 2d 6c 65 66 74 29 29 0a 3b 3b 3b 20 09 09 09 20 -left)).;;; ...
bd80: 20 20 20 20 20 28 72 65 73 70 6f 6e 73 65 20 28 (response (
bd90: 63 64 72 20 72 65 73 70 6f 6e 73 65 73 2d 6c 65 cdr responses-le
bda0: 66 74 29 29 29 20 20 0a 3b 3b 3b 20 09 09 09 20 ft))) .;;; ...
bdb0: 28 63 61 6c 6c 2d 64 65 6c 69 76 65 72 2d 72 65 (call-deliver-re
bdc0: 73 70 6f 6e 73 65 20 61 63 66 67 20 28 77 69 74 sponse acfg (wit
bdd0: 65 6d 2d 72 69 70 61 64 64 72 20 77 69 74 65 6d em-ripaddr witem
bde0: 29 28 77 69 74 65 6d 2d 72 70 6f 72 74 20 77 69 )(witem-rport wi
bdf0: 74 65 6d 29 0a 3b 3b 3b 20 09 09 09 09 09 09 28 tem).;;; ......(
be00: 77 69 74 65 6d 2d 63 6f 6f 6b 69 65 20 77 69 74 witem-cookie wit
be10: 65 6d 29 28 77 69 74 65 6d 2d 72 65 73 75 6c 74 em)(witem-result
be20: 20 77 69 74 65 6d 29 29 29 0a 3b 3b 3b 20 09 09 witem))).;;; ..
be30: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 64 (loop (cd
be40: 72 20 72 65 73 70 6f 6e 73 65 73 2d 6c 65 66 74 r responses-left
be50: 29 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 29 29 )))))).;;; .. ))
be60: 29 0a 3b 3b 3b 20 09 20 27 28 77 71 75 65 75 65 ).;;; . '(wqueue
be70: 20 72 77 71 75 65 75 65 20 72 71 75 65 75 65 29 rwqueue rqueue)
be80: 29 0a 3b 3b 3b 20 09 0a 3b 3b 3b 20 09 3b 3b 20 ).;;; ..;;; .;;
be90: 68 61 6e 64 6c 65 20 6d 69 73 63 20 71 75 65 75 handle misc queu
bea0: 65 0a 3b 3b 3b 20 09 3b 3b 0a 3b 3b 3b 20 09 3b e.;;; .;;.;;; .;
beb0: 3b 20 28 70 72 69 6e 74 20 22 70 72 6f 63 65 73 ; (print "proces
bec0: 73 69 6e 67 20 6d 69 73 63 20 71 75 65 75 65 22 sing misc queue"
bed0: 29 0a 3b 3b 3b 20 09 28 6c 65 74 20 28 28 71 75 ).;;; .(let ((qu
bee0: 65 75 65 20 28 71 75 65 75 65 2d 73 79 6d 2d 3e eue (queue-sym->
bef0: 71 75 65 75 65 20 27 6d 69 73 63 29 29 29 0a 3b queue 'misc))).;
bf00: 3b 3b 20 09 20 20 28 64 6f 71 75 65 75 65 20 61 ;; . (doqueue a
bf10: 63 66 67 20 71 75 65 75 65 20 66 6e 61 6d 65 20 cfg queue fname
bf20: 64 62 64 61 74 20 64 62 68 29 29 0a 3b 3b 3b 20 dbdat dbh)).;;;
bf30: 09 3b 3b 20 2e 2e 2e 2e 0a 3b 3b 3b 20 09 28 73 .;; .....;;; .(s
bf40: 61 76 65 2d 64 62 68 20 61 63 66 67 20 66 6e 61 ave-dbh acfg fna
bf50: 6d 65 20 64 62 64 61 74 29 0a 3b 3b 3b 20 09 23 me dbdat).;;; .#
bf60: 74 20 3b 3b 20 6a 75 73 74 20 74 6f 20 6c 65 74 t ;; just to let
bf70: 20 74 68 65 20 74 65 73 74 73 20 6b 6e 6f 77 20 the tests know
bf80: 77 65 20 67 6f 74 20 68 65 72 65 0a 3b 3b 3b 20 we got here.;;;
bf90: 09 29 0a 3b 3b 3b 20 20 20 20 20 20 20 23 66 20 .).;;; #f
bfa0: 3b 3b 20 6e 6f 74 68 69 6e 67 20 70 72 6f 63 65 ;; nothing proce
bfb0: 73 73 65 64 0a 3b 3b 3b 20 20 20 20 20 20 20 29 ssed.;;; )
bfc0: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 72 75 ).;;; .;;; ;; ru
bfd0: 6e 20 61 6c 6c 20 71 75 65 75 65 73 20 69 6e 20 n all queues in
bfe0: 70 61 72 61 6c 6c 65 6c 20 70 65 72 20 64 62 20 parallel per db
bff0: 62 75 74 20 73 65 71 75 65 6e 74 69 61 6c 6c 79 but sequentially
c000: 20 70 65 72 20 71 75 65 75 65 20 66 6f 72 20 74 per queue for t
c010: 68 61 74 20 64 62 2e 0a 3b 3b 3b 20 3b 3b 20 20 hat db..;;; ;;
c020: 2d 20 70 72 6f 63 65 73 73 20 74 68 65 20 71 75 - process the qu
c030: 65 75 65 73 20 65 76 65 72 79 20 35 30 30 20 6f eues every 500 o
c040: 72 20 73 6f 20 6d 73 0a 3b 3b 3b 20 3b 3b 20 20 r so ms.;;; ;;
c050: 2d 20 61 6c 6c 6f 77 20 66 6f 72 20 6c 6f 6e 67 - allow for long
c060: 20 72 75 6e 6e 69 6e 67 20 71 75 65 72 69 65 73 running queries
c070: 20 74 6f 20 63 6f 6e 74 69 6e 75 65 20 62 75 74 to continue but
c080: 20 61 6c 6c 20 6f 74 68 65 72 20 61 63 74 69 76 all other activ
c090: 69 74 69 65 73 20 66 6f 72 20 74 68 61 74 0a 3b ities for that.;
c0a0: 3b 3b 20 3b 3b 20 20 20 20 64 62 20 77 69 6c 6c ;; ;; db will
c0b0: 20 62 65 20 62 6c 6f 63 6b 65 64 2e 0a 3b 3b 3b be blocked..;;;
c0c0: 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 ;;.;;; (define
c0d0: 28 77 6f 72 6b 2d 71 75 65 75 65 2d 70 72 6f 63 (work-queue-proc
c0e0: 65 73 73 6f 72 20 61 63 66 67 29 0a 3b 3b 3b 20 essor acfg).;;;
c0f0: 20 20 28 6c 65 74 2a 20 28 28 74 68 72 65 61 64 (let* ((thread
c100: 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 s (make-hash-tab
c110: 6c 65 29 29 29 20 3b 3b 20 66 6e 61 6d 65 20 3d le))) ;; fname =
c120: 3e 20 74 68 72 65 61 64 0a 3b 3b 3b 20 20 20 20 > thread.;;;
c130: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 66 6e 61 (let loop ((fna
c140: 6d 65 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 mes (hash-t
c150: 61 62 6c 65 2d 6b 65 79 73 20 28 61 72 65 61 2d able-keys (area-
c160: 77 71 75 65 75 65 73 20 61 63 66 67 29 29 29 0a wqueues acfg))).
c170: 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 74 61 72 ;;; . (tar
c180: 67 65 74 2d 74 69 6d 65 20 28 2b 20 28 63 75 72 get-time (+ (cur
c190: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
c1a0: 73 29 20 35 30 29 29 29 0a 3b 3b 3b 20 20 20 20 s) 50))).;;;
c1b0: 20 20 20 3b 3b 28 69 66 20 28 6e 6f 74 20 28 6e ;;(if (not (n
c1c0: 75 6c 6c 3f 20 66 6e 61 6d 65 73 29 29 28 70 72 ull? fnames))(pr
c1d0: 69 6e 74 20 22 50 72 6f 63 65 73 73 69 6e 67 20 int "Processing
c1e0: 66 6f 72 20 74 68 65 73 65 20 64 61 74 61 62 61 for these databa
c1f0: 73 65 73 3a 20 22 20 66 6e 61 6d 65 73 29 29 0a ses: " fnames)).
c200: 3b 3b 3b 20 20 20 20 20 20 20 28 66 6f 72 2d 65 ;;; (for-e
c210: 61 63 68 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 ach.;;; (
c220: 6c 61 6d 62 64 61 20 28 66 6e 61 6d 65 29 0a 3b lambda (fname).;
c230: 3b 3b 20 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; . ;; (print "
c240: 70 72 6f 63 65 73 73 69 6e 67 20 66 6f 72 20 22 processing for "
c250: 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 20 3b 3b fname).;;; . ;;
c260: 28 70 72 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 (process-db-quer
c270: 69 65 73 20 61 63 66 67 20 66 6e 61 6d 65 29 29 ies acfg fname))
c280: 0a 3b 3b 3b 20 09 20 28 6c 65 74 20 28 28 74 68 .;;; . (let ((th
c290: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
c2a0: 2f 64 65 66 61 75 6c 74 20 74 68 72 65 61 64 73 /default threads
c2b0: 20 66 6e 61 6d 65 20 23 66 29 29 29 0a 3b 3b 3b fname #f))).;;;
c2c0: 20 09 20 20 20 28 69 66 20 28 61 6e 64 20 74 68 . (if (and th
c2d0: 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 74 (not (member (t
c2e0: 68 72 65 61 64 2d 73 74 61 74 65 20 74 68 29 20 hread-state th)
c2f0: 27 28 64 65 61 64 20 74 65 72 6d 69 6e 61 74 65 '(dead terminate
c300: 64 29 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 d)))).;;; .
c310: 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 (begin.;;; ..
c320: 28 70 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a (print "WARNING:
c330: 20 77 6f 72 6b 65 72 20 74 68 72 65 61 64 20 66 worker thread f
c340: 6f 72 20 22 20 66 6e 61 6d 65 20 22 20 69 73 20 or " fname " is
c350: 74 61 6b 69 6e 67 20 61 20 6c 6f 6e 67 20 74 69 taking a long ti
c360: 6d 65 2e 22 29 0a 3b 3b 3b 20 09 09 20 28 70 72 me.").;;; .. (pr
c370: 69 6e 74 20 22 54 68 72 65 61 64 20 69 73 20 69 int "Thread is i
c380: 6e 20 73 74 61 74 65 20 22 20 28 74 68 72 65 61 n state " (threa
c390: 64 2d 73 74 61 74 65 20 74 68 29 29 29 0a 3b 3b d-state th))).;;
c3a0: 3b 20 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 ; . (let (
c3b0: 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th1 (make-threa
c3c0: 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b d (lambda ().;;;
c3d0: 20 09 09 09 09 09 20 3b 3b 20 28 63 61 74 63 68 ..... ;; (catch
c3e0: 2d 61 6e 64 2d 64 75 6d 70 0a 3b 3b 3b 20 09 09 -and-dump.;;; ..
c3f0: 09 09 09 20 3b 3b 20 20 28 6c 61 6d 62 64 61 20 ... ;; (lambda
c400: 28 29 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 ().;;; .....
c410: 3b 3b 20 28 70 72 69 6e 74 20 22 50 72 6f 63 65 ;; (print "Proce
c420: 73 73 20 71 75 65 72 69 65 73 20 66 6f 72 20 22 ss queries for "
c430: 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 09 09 09 fname).;;; ....
c440: 09 20 20 20 20 28 6c 65 74 20 28 28 73 74 61 72 . (let ((star
c450: 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d t-time (current-
c460: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a milliseconds))).
c470: 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 20 20 28 ;;; ..... (
c480: 70 72 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 69 process-db-queri
c490: 65 73 20 61 63 66 67 20 66 6e 61 6d 65 29 0a 3b es acfg fname).;
c4a0: 3b 3b 20 09 09 09 09 09 20 20 20 20 20 20 3b 3b ;; ..... ;;
c4b0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
c4c0: 30 2e 30 31 29 20 3b 3b 20 6e 65 65 64 20 74 68 0.01) ;; need th
c4d0: 65 20 74 68 72 65 61 64 20 74 6f 20 74 61 6b 65 e thread to take
c4e0: 20 61 74 20 6c 65 61 73 74 20 73 6f 6d 65 20 74 at least some t
c4f0: 69 6d 65 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 ime.;;; .....
c500: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 (hash-table-d
c510: 65 6c 65 74 65 21 20 74 68 72 65 61 64 73 20 66 elete! threads f
c520: 6e 61 6d 65 29 29 20 3b 3b 20 6e 6f 20 6d 75 74 name)) ;; no mut
c530: 65 78 65 73 3f 0a 3b 3b 3b 20 09 09 09 09 09 20 exes?.;;; .....
c540: 20 20 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 09 fname).;;; ..
c550: 09 09 09 20 20 22 74 68 31 22 29 29 29 20 3b 3b ... "th1"))) ;;
c560: 20 29 29 0a 3b 3b 3b 20 09 09 20 28 68 61 73 68 )).;;; .. (hash
c570: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 68 72 65 -table-set! thre
c580: 61 64 73 20 66 6e 61 6d 65 20 74 68 31 29 0a 3b ads fname th1).;
c590: 3b 3b 20 09 09 20 28 74 68 72 65 61 64 2d 73 74 ;; .. (thread-st
c5a0: 61 72 74 21 20 74 68 31 29 29 29 29 29 0a 3b 3b art! th1))))).;;
c5b0: 3b 20 20 20 20 20 20 20 20 66 6e 61 6d 65 73 29 ; fnames)
c5c0: 0a 3b 3b 3b 20 20 20 20 20 20 20 3b 3b 20 28 74 .;;; ;; (t
c5d0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 hread-sleep! 0.1
c5e0: 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 74 68 ) ;; give the th
c5f0: 72 65 61 64 73 20 73 6f 6d 65 20 74 69 6d 65 20 reads some time
c600: 74 6f 20 70 72 6f 63 65 73 73 20 72 65 71 75 65 to process reque
c610: 73 74 73 0a 3b 3b 3b 20 20 20 20 20 20 20 3b 3b sts.;;; ;;
c620: 20 62 75 72 6e 20 74 69 6d 65 20 75 6e 74 69 6c burn time until
c630: 20 34 30 30 6d 73 20 69 73 20 75 70 0a 3b 3b 3b 400ms is up.;;;
c640: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 6f (let ((no
c650: 77 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d w-time (current-
c660: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a milliseconds))).
c670: 3b 3b 3b 20 09 28 69 66 20 28 3c 20 6e 6f 77 2d ;;; .(if (< now-
c680: 74 69 6d 65 20 74 61 72 67 65 74 2d 74 69 6d 65 time target-time
c690: 29 0a 3b 3b 3b 20 09 20 20 20 20 28 6c 65 74 20 ).;;; . (let
c6a0: 28 28 64 65 6c 74 61 20 28 2d 20 74 61 72 67 65 ((delta (- targe
c6b0: 74 2d 74 69 6d 65 20 6e 6f 77 2d 74 69 6d 65 29 t-time now-time)
c6c0: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 74 )).;;; . (t
c6d0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 hread-sleep! (/
c6e0: 64 65 6c 74 61 20 31 30 30 30 29 29 29 29 29 0a delta 1000))))).
c6f0: 3b 3b 3b 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 ;;; (loop
c700: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
c710: 20 28 61 72 65 61 2d 77 71 75 65 75 65 73 20 61 (area-wqueues a
c720: 63 66 67 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 cfg)).;;; . (
c730: 2b 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 + (current-milli
c740: 73 65 63 6f 6e 64 73 29 20 35 30 29 29 29 29 29 seconds) 50)))))
c750: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d .;;; .;;; ;;====
c760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c7a0: 3d 3d 0a 3b 3b 3b 20 3b 3b 20 53 20 54 20 41 20 ==.;;; ;; S T A
c7b0: 54 20 53 20 20 20 47 20 41 20 54 20 48 20 45 20 T S G A T H E
c7c0: 52 20 49 20 4e 20 47 0a 3b 3b 3b 20 3b 3b 3d 3d R I N G.;;; ;;==
c7d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c7e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c7f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c810: 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 ====.;;; .;;; (d
c820: 65 66 73 74 72 75 63 74 20 73 74 61 74 0a 3b 3b efstruct stat.;;
c830: 3b 20 20 20 28 71 63 6f 75 6e 74 2d 61 76 67 20 ; (qcount-avg
c840: 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
c850: 20 20 20 20 20 3b 3b 20 63 6f 61 72 73 65 20 72 ;; coarse r
c860: 75 6e 6e 69 6e 67 20 61 76 65 72 61 67 65 0a 3b unning average.;
c870: 3b 3b 20 20 20 28 71 74 69 6d 65 2d 61 76 67 20 ;; (qtime-avg
c880: 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 0)
c890: 20 20 20 20 20 20 3b 3b 20 63 6f 61 72 73 65 20 ;; coarse
c8a0: 72 75 6e 6e 69 6e 67 20 61 76 65 72 61 67 65 0a running average.
c8b0: 3b 3b 3b 20 20 20 28 71 63 6f 75 6e 74 20 20 20 ;;; (qcount
c8c0: 20 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 0)
c8d0: 20 20 20 20 20 20 20 3b 3b 20 74 6f 74 61 6c 0a ;; total.
c8e0: 3b 3b 3b 20 20 20 28 71 74 69 6d 65 20 20 20 20 ;;; (qtime
c8f0: 20 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 0)
c900: 20 20 20 20 20 20 20 3b 3b 20 74 6f 74 61 6c 0a ;; total.
c910: 3b 3b 3b 20 20 20 28 6c 61 73 74 2d 71 63 6f 75 ;;; (last-qcou
c920: 6e 74 20 30 29 20 20 20 20 20 20 20 20 20 20 20 nt 0)
c930: 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 0a ;; last .
c940: 3b 3b 3b 20 20 20 28 6c 61 73 74 2d 71 74 69 6d ;;; (last-qtim
c950: 65 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 e 0)
c960: 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 0a 3b ;; last.;
c970: 3b 3b 20 20 20 28 64 62 73 20 20 20 20 20 20 20 ;; (dbs
c980: 20 27 28 29 29 20 20 20 20 20 20 20 20 20 20 20 '())
c990: 20 20 20 20 20 20 3b 3b 20 6c 69 73 74 20 6f 66 ;; list of
c9a0: 20 64 62 20 66 69 6c 65 73 20 68 61 6e 64 6c 65 db files handle
c9b0: 64 20 62 79 20 74 68 69 73 20 6e 6f 64 65 0a 3b d by this node.;
c9c0: 3b 3b 20 20 20 28 77 68 65 6e 20 20 20 20 20 20 ;; (when
c9d0: 20 20 30 29 29 20 20 20 20 20 20 20 20 20 20 20 0))
c9e0: 20 20 20 20 20 20 3b 3b 20 77 68 65 6e 20 74 68 ;; when th
c9f0: 65 20 6c 61 73 74 20 71 75 65 72 79 20 68 61 70 e last query hap
ca00: 70 65 6e 65 64 20 2d 20 73 65 63 6f 6e 64 73 0a pened - seconds.
ca10: 3b 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 ;;; .;;; .;;; (d
ca20: 65 66 69 6e 65 20 28 75 70 64 61 74 65 2d 73 74 efine (update-st
ca30: 61 74 73 20 61 63 66 67 20 66 6e 61 6d 65 20 62 ats acfg fname b
ca40: 75 63 6b 65 74 20 64 75 72 61 74 69 6f 6e 20 6e ucket duration n
ca50: 75 6d 71 75 65 72 69 65 73 29 0a 3b 3b 3b 20 20 umqueries).;;;
ca60: 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 66 (let* ((key f
ca70: 6e 61 6d 65 29 20 3b 3b 20 66 6f 72 20 6e 6f 77 name) ;; for now
ca80: 20 64 6f 20 6e 6f 74 20 75 73 65 20 62 75 63 6b do not use buck
ca90: 65 74 2e 20 57 61 73 3a 20 28 63 6f 6e 63 20 66 et. Was: (conc f
caa0: 6e 61 6d 65 20 22 2d 22 20 62 75 63 6b 65 74 29 name "-" bucket)
cab0: 29 20 3b 3b 20 6c 61 7a 79 20 62 75 74 20 67 6f ) ;; lazy but go
cac0: 6f 64 20 65 6e 6f 75 67 68 0a 3b 3b 3b 20 09 20 od enough.;;; .
cad0: 28 73 74 61 74 73 20 28 6f 72 20 28 68 61 73 68 (stats (or (hash
cae0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
caf0: 6c 74 20 28 61 72 65 61 2d 73 74 61 74 73 20 61 lt (area-stats a
cb00: 63 66 67 29 20 6b 65 79 20 23 66 29 0a 3b 3b 3b cfg) key #f).;;;
cb10: 20 09 09 20 20 20 20 28 6c 65 74 20 28 28 6e 65 .. (let ((ne
cb20: 77 73 74 61 74 73 20 28 6d 61 6b 65 2d 73 74 61 wstats (make-sta
cb30: 74 29 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 t))).;;; ..
cb40: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
cb50: 21 20 28 61 72 65 61 2d 73 74 61 74 73 20 61 63 ! (area-stats ac
cb60: 66 67 29 20 6b 65 79 20 6e 65 77 73 74 61 74 73 fg) key newstats
cb70: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 6e 65 ).;;; .. ne
cb80: 77 73 74 61 74 73 29 29 29 29 0a 3b 3b 3b 20 20 wstats)))).;;;
cb90: 20 20 20 3b 3b 20 77 68 65 6e 20 74 68 65 20 6c ;; when the l
cba0: 61 73 74 20 71 75 65 72 79 20 68 61 70 70 65 6e ast query happen
cbb0: 64 65 64 20 28 75 73 65 64 20 74 6f 20 72 65 6d ded (used to rem
cbc0: 6f 76 65 20 74 68 65 20 66 6e 61 6d 65 20 66 72 ove the fname fr
cbd0: 6f 6d 20 74 68 65 20 61 63 74 69 76 65 20 6c 69 om the active li
cbe0: 73 74 29 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 st).;;; (sta
cbf0: 74 2d 77 68 65 6e 2d 73 65 74 21 20 73 74 61 74 t-when-set! stat
cc00: 73 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e s (current-secon
cc10: 64 73 29 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 ds)).;;; ;;
cc20: 6c 61 73 74 20 76 61 6c 75 65 73 0a 3b 3b 3b 20 last values.;;;
cc30: 20 20 20 20 28 73 74 61 74 2d 6c 61 73 74 2d 71 (stat-last-q
cc40: 63 6f 75 6e 74 2d 73 65 74 21 20 73 74 61 74 73 count-set! stats
cc50: 20 6e 75 6d 71 75 65 72 69 65 73 29 0a 3b 3b 3b numqueries).;;;
cc60: 20 20 20 20 20 28 73 74 61 74 2d 6c 61 73 74 2d (stat-last-
cc70: 71 74 69 6d 65 2d 73 65 74 21 20 20 73 74 61 74 qtime-set! stat
cc80: 73 20 64 75 72 61 74 69 6f 6e 29 0a 3b 3b 3b 20 s duration).;;;
cc90: 20 20 20 20 3b 3b 20 74 6f 74 61 6c 20 6f 76 65 ;; total ove
cca0: 72 20 70 72 6f 63 65 73 73 20 6c 69 66 65 74 69 r process lifeti
ccb0: 6d 65 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 me.;;; (stat
ccc0: 2d 71 63 6f 75 6e 74 2d 73 65 74 21 20 73 74 61 -qcount-set! sta
ccd0: 74 73 20 28 2b 20 28 73 74 61 74 2d 71 63 6f 75 ts (+ (stat-qcou
cce0: 6e 74 20 73 74 61 74 73 29 20 6e 75 6d 71 75 65 nt stats) numque
ccf0: 72 69 65 73 29 29 0a 3b 3b 3b 20 20 20 20 20 28 ries)).;;; (
cd00: 73 74 61 74 2d 71 74 69 6d 65 2d 73 65 74 21 20 stat-qtime-set!
cd10: 20 73 74 61 74 73 20 28 2b 20 28 73 74 61 74 2d stats (+ (stat-
cd20: 71 74 69 6d 65 20 20 73 74 61 74 73 29 20 64 75 qtime stats) du
cd30: 72 61 74 69 6f 6e 29 29 0a 3b 3b 3b 20 20 20 20 ration)).;;;
cd40: 20 3b 3b 20 63 6f 61 72 73 65 20 61 76 65 72 61 ;; coarse avera
cd50: 67 65 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 ge.;;; (stat
cd60: 2d 71 63 6f 75 6e 74 2d 61 76 67 2d 73 65 74 21 -qcount-avg-set!
cd70: 20 73 74 61 74 73 20 28 2f 20 28 2b 20 28 73 74 stats (/ (+ (st
cd80: 61 74 2d 71 63 6f 75 6e 74 2d 61 76 67 20 73 74 at-qcount-avg st
cd90: 61 74 73 29 20 6e 75 6d 71 75 65 72 69 65 73 29 ats) numqueries)
cda0: 20 32 29 29 0a 3b 3b 3b 20 20 20 20 20 28 73 74 2)).;;; (st
cdb0: 61 74 2d 71 74 69 6d 65 2d 61 76 67 2d 73 65 74 at-qtime-avg-set
cdc0: 21 20 20 73 74 61 74 73 20 28 2f 20 28 2b 20 28 ! stats (/ (+ (
cdd0: 73 74 61 74 2d 71 74 69 6d 65 2d 61 76 67 20 20 stat-qtime-avg
cde0: 73 74 61 74 73 29 20 64 75 72 61 74 69 6f 6e 29 stats) duration)
cdf0: 20 20 20 32 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 2)).;;; .;;;
ce00: 20 20 20 20 3b 3b 20 68 65 72 65 20 69 73 20 77 ;; here is w
ce10: 68 65 72 65 20 77 65 20 61 64 64 20 74 68 65 20 here we add the
ce20: 73 74 61 74 73 20 66 6f 72 20 61 20 67 69 76 65 stats for a give
ce30: 6e 20 64 62 66 69 6c 65 0a 3b 3b 3b 20 20 20 20 n dbfile.;;;
ce40: 20 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d 62 65 (if (not (membe
ce50: 72 20 66 6e 61 6d 65 20 28 73 74 61 74 2d 64 62 r fname (stat-db
ce60: 73 20 73 74 61 74 73 29 29 29 0a 3b 3b 3b 20 09 s stats))).;;; .
ce70: 28 73 74 61 74 2d 64 62 73 2d 73 65 74 21 20 73 (stat-dbs-set! s
ce80: 74 61 74 73 20 28 63 6f 6e 73 20 66 6e 61 6d 65 tats (cons fname
ce90: 20 28 73 74 61 74 2d 64 62 73 20 73 74 61 74 73 (stat-dbs stats
cea0: 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 )))).;;; .;;;
ceb0: 20 20 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b )).;;; .;;; ;;
cec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ced0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cf00: 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 53 20 ======.;;; ;; S
cf10: 45 20 52 20 56 20 45 20 52 20 20 20 53 20 54 20 E R V E R S T
cf20: 55 20 46 20 46 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d U F F .;;; ;;===
cf30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cf40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cf50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cf60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cf70: 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 ===.;;; .;;; ;;
cf80: 74 68 69 73 20 64 6f 65 73 20 4e 4f 54 20 72 65 this does NOT re
cf90: 74 75 72 6e 21 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b turn!.;;; ;;.;;;
cfa0: 20 28 64 65 66 69 6e 65 20 28 66 69 6e 64 2d 66 (define (find-f
cfb0: 72 65 65 2d 70 6f 72 74 2d 61 6e 64 2d 6f 70 65 ree-port-and-ope
cfc0: 6e 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 28 6c n acfg).;;; (l
cfd0: 65 74 20 28 28 70 6f 72 74 20 28 6f 72 20 28 61 et ((port (or (a
cfe0: 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 20 33 rea-port acfg) 3
cff0: 32 30 30 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 200))).;;; (
d000: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
d010: 73 0a 3b 3b 3b 20 09 65 78 6e 0a 3b 3b 3b 20 09 s.;;; .exn.;;; .
d020: 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 28 70 (begin.;;; . (p
d030: 72 69 6e 74 20 22 49 4e 46 4f 3a 20 63 61 6e 6e rint "INFO: cann
d040: 6f 74 20 62 69 6e 64 20 74 6f 20 70 6f 72 74 20 ot bind to port
d050: 22 20 28 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 " (rpc:default-s
d060: 65 72 76 65 72 2d 70 6f 72 74 29 20 22 2c 20 74 erver-port) ", t
d070: 72 79 69 6e 67 20 6e 65 78 74 20 70 6f 72 74 22 rying next port"
d080: 29 0a 3b 3b 3b 20 09 20 20 28 61 72 65 61 2d 70 ).;;; . (area-p
d090: 6f 72 74 2d 73 65 74 21 20 61 63 66 67 20 28 2b ort-set! acfg (+
d0a0: 20 70 6f 72 74 20 31 29 29 0a 3b 3b 3b 20 09 20 port 1)).;;; .
d0b0: 20 28 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 (find-free-port
d0c0: 2d 61 6e 64 2d 6f 70 65 6e 20 61 63 66 67 29 29 -and-open acfg))
d0d0: 0a 3b 3b 3b 20 20 20 20 20 20 20 28 72 70 63 3a .;;; (rpc:
d0e0: 64 65 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 default-server-p
d0f0: 6f 72 74 20 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 ort port).;;;
d100: 20 20 20 20 28 61 72 65 61 2d 70 6f 72 74 2d 73 (area-port-s
d110: 65 74 21 20 61 63 66 67 20 70 6f 72 74 29 0a 3b et! acfg port).;
d120: 3b 3b 20 20 20 20 20 20 20 28 74 63 70 2d 72 65 ;; (tcp-re
d130: 61 64 2d 74 69 6d 65 6f 75 74 20 31 32 30 30 30 ad-timeout 12000
d140: 30 29 0a 3b 3b 3b 20 20 20 20 20 20 20 3b 3b 20 0).;;; ;;
d150: 28 28 72 70 63 3a 6d 61 6b 65 2d 73 65 72 76 65 ((rpc:make-serve
d160: 72 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 70 6f r (tcp-listen po
d170: 72 74 29 29 20 23 74 29 0a 3b 3b 3b 20 20 20 20 rt)) #t).;;;
d180: 20 20 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 28 (tcp-listen (
d190: 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 rpc:default-serv
d1a0: 65 72 2d 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 20 er-port).;;;
d1b0: 20 20 20 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b )))).;;; .;;;
d1c0: 20 3b 3b 20 72 65 67 69 73 74 65 72 20 74 68 69 ;; register thi
d1d0: 73 20 6e 6f 64 65 20 62 79 20 70 75 74 74 69 6e s node by puttin
d1e0: 67 20 61 20 70 61 63 6b 65 74 20 69 6e 74 6f 20 g a packet into
d1f0: 74 68 65 20 70 6b 74 73 20 64 69 72 2e 0a 3b 3b the pkts dir..;;
d200: 3b 20 3b 3b 20 6c 6f 6f 6b 20 66 6f 72 20 6f 74 ; ;; look for ot
d210: 68 65 72 20 73 65 72 76 65 72 73 0a 3b 3b 3b 20 her servers.;;;
d220: 3b 3b 20 63 6f 6e 74 61 63 74 20 6f 74 68 65 72 ;; contact other
d230: 20 73 65 72 76 65 72 73 20 61 6e 64 20 63 6f 6d servers and com
d240: 70 69 6c 65 20 6c 69 73 74 20 6f 66 20 73 65 72 pile list of ser
d250: 76 65 72 73 0a 3b 3b 3b 20 3b 3b 20 74 68 65 72 vers.;;; ;; ther
d260: 65 20 61 72 65 20 74 77 6f 20 74 79 70 65 73 20 e are two types
d270: 6f 66 20 73 65 72 76 65 72 0a 3b 3b 3b 20 3b 3b of server.;;; ;;
d280: 20 20 20 20 20 6d 61 69 6e 20 73 65 72 76 65 72 main server
d290: 73 20 2d 20 64 61 73 68 62 6f 61 72 64 73 2c 20 s - dashboards,
d2a0: 72 75 6e 6e 65 72 73 20 61 6e 64 20 64 65 64 69 runners and dedi
d2b0: 63 61 74 65 64 20 73 65 72 76 65 72 73 20 2d 20 cated servers -
d2c0: 6e 65 65 64 20 70 6b 74 0a 3b 3b 3b 20 3b 3b 20 need pkt.;;; ;;
d2d0: 20 20 20 20 70 61 73 73 69 76 65 20 73 65 72 76 passive serv
d2e0: 65 72 73 20 2d 20 74 65 73 74 20 65 78 65 63 75 ers - test execu
d2f0: 74 65 72 73 2c 20 73 74 65 70 20 63 61 6c 6c 73 ters, step calls
d300: 2c 20 6c 69 73 74 2d 72 75 6e 73 20 2d 20 6e 6f , list-runs - no
d310: 20 70 6b 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 pkt.;;; ;;.;;;
d320: 28 64 65 66 69 6e 65 20 28 72 65 67 69 73 74 65 (define (registe
d330: 72 2d 6e 6f 64 65 20 61 63 66 67 20 68 6f 73 74 r-node acfg host
d340: 69 70 20 70 6f 72 74 2d 6e 75 6d 29 0a 3b 3b 3b ip port-num).;;;
d350: 20 20 20 3b 3b 28 6d 75 74 65 78 2d 6c 6f 63 6b ;;(mutex-lock
d360: 21 20 28 61 72 65 61 2d 6d 75 74 65 78 20 61 63 ! (area-mutex ac
d370: 66 67 29 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a fg)).;;; (let*
d380: 20 28 28 73 65 72 76 65 72 2d 74 79 70 65 20 20 ((server-type
d390: 28 61 72 65 61 2d 73 65 72 76 65 72 2d 74 79 70 (area-server-typ
d3a0: 65 20 61 63 66 67 29 29 20 3b 3b 20 61 75 74 6f e acfg)) ;; auto
d3b0: 2c 20 6d 61 69 6e 2c 20 70 61 73 73 69 76 65 20 , main, passive
d3c0: 28 6e 6f 20 70 6b 74 20 63 72 65 61 74 65 64 29 (no pkt created)
d3d0: 0a 3b 3b 3b 20 09 20 28 62 65 73 74 2d 69 70 20 .;;; . (best-ip
d3e0: 20 20 20 20 20 28 6f 72 20 68 6f 73 74 69 70 20 (or hostip
d3f0: 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 (get-my-best-add
d400: 72 65 73 73 29 29 29 0a 3b 3b 3b 20 09 20 28 6d ress))).;;; . (m
d410: 74 64 69 72 20 20 20 20 20 20 20 20 28 61 72 65 tdir (are
d420: 61 2d 64 62 64 69 72 20 61 63 66 67 29 29 0a 3b a-dbdir acfg)).;
d430: 3b 3b 20 09 20 28 70 6b 74 64 69 72 20 20 20 20 ;; . (pktdir
d440: 20 20 20 28 61 72 65 61 2d 70 6b 74 73 64 69 72 (area-pktsdir
d450: 20 61 63 66 67 29 29 29 20 3b 3b 20 63 6f 6e 63 acfg))) ;; conc
d460: 20 6d 74 64 69 72 20 22 2f 2e 73 65 72 76 65 72 mtdir "/.server
d470: 2d 70 6b 74 73 22 29 29 29 0a 3b 3b 3b 20 20 20 -pkts"))).;;;
d480: 20 20 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 (print "Regist
d490: 65 72 69 6e 67 20 6e 6f 64 65 20 22 20 62 65 73 ering node " bes
d4a0: 74 2d 69 70 20 22 3a 22 20 70 6f 72 74 2d 6e 75 t-ip ":" port-nu
d4b0: 6d 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 28 m).;;; (if (
d4c0: 6e 6f 74 20 6d 74 64 69 72 29 20 3b 3b 20 72 65 not mtdir) ;; re
d4d0: 71 75 69 72 65 20 61 20 68 6f 6d 65 20 66 6f 72 quire a home for
d4e0: 20 74 68 69 73 20 6e 6f 64 65 20 74 6f 20 70 75 this node to pu
d4f0: 74 20 6f 72 20 66 69 6e 64 20 64 61 74 61 62 61 t or find databa
d500: 73 65 73 0a 3b 3b 3b 20 09 23 66 0a 3b 3b 3b 20 ses.;;; .#f.;;;
d510: 09 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 28 .(begin.;;; . (
d520: 69 66 20 20 28 6e 6f 74 20 28 64 69 72 65 63 74 if (not (direct
d530: 6f 72 79 3f 20 70 6b 74 64 69 72 29 29 28 63 72 ory? pktdir))(cr
d540: 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 70 eate-directory p
d550: 6b 74 64 69 72 29 29 0a 3b 3b 3b 20 09 20 20 3b ktdir)).;;; . ;
d560: 3b 20 73 65 72 76 65 72 20 69 73 20 73 74 61 72 ; server is star
d570: 74 65 64 2c 20 6e 6f 77 20 63 72 65 61 74 65 20 ted, now create
d580: 70 6b 74 20 69 66 20 6e 65 65 64 65 64 0a 3b 3b pkt if needed.;;
d590: 3b 20 09 20 20 28 70 72 69 6e 74 20 22 53 74 61 ; . (print "Sta
d5a0: 72 74 69 6e 67 20 73 65 72 76 65 72 20 69 6e 20 rting server in
d5b0: 22 20 73 65 72 76 65 72 2d 74 79 70 65 20 22 20 " server-type "
d5c0: 6d 6f 64 65 20 77 69 74 68 20 70 6f 72 74 20 22 mode with port "
d5d0: 20 70 6f 72 74 2d 6e 75 6d 29 0a 3b 3b 3b 20 09 port-num).;;; .
d5e0: 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 73 65 (if (member se
d5f0: 72 76 65 72 2d 74 79 70 65 20 27 28 61 75 74 6f rver-type '(auto
d600: 20 6d 61 69 6e 29 29 20 3b 3b 20 54 4f 44 4f 3a main)) ;; TODO:
d610: 20 69 66 20 61 75 74 6f 2c 20 63 6f 75 6e 74 20 if auto, count
d620: 6e 75 6d 62 65 72 20 6f 66 20 73 65 72 76 65 72 number of server
d630: 73 20 72 65 67 69 73 74 65 72 73 2c 20 69 66 20 s registers, if
d640: 3e 20 33 20 74 68 65 6e 20 64 6f 6e 27 74 20 70 > 3 then don't p
d650: 75 74 20 6f 75 74 20 61 20 70 6b 74 0a 3b 3b 3b ut out a pkt.;;;
d660: 20 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b . (begin.;
d670: 3b 3b 20 09 09 28 61 72 65 61 2d 70 6b 74 69 64 ;; ..(area-pktid
d680: 2d 73 65 74 21 20 61 63 66 67 0a 3b 3b 3b 20 09 -set! acfg.;;; .
d690: 09 09 09 20 28 77 72 69 74 65 2d 61 6c 69 73 74 ... (write-alist
d6a0: 2d 3e 70 6b 74 0a 3b 3b 3b 20 09 09 09 09 20 20 ->pkt.;;; ....
d6b0: 70 6b 74 64 69 72 20 0a 3b 3b 3b 20 09 09 09 09 pktdir .;;; ....
d6c0: 20 20 60 28 28 68 6f 73 74 6e 61 6d 65 20 2e 20 `((hostname .
d6d0: 2c 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 ,(get-host-name)
d6e0: 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 28 69 ).;;; .... (i
d6f0: 70 61 64 64 72 20 20 20 2e 20 2c 62 65 73 74 2d paddr . ,best-
d700: 69 70 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 ip).;;; ....
d710: 28 70 6f 72 74 20 20 20 20 20 2e 20 2c 70 6f 72 (port . ,por
d720: 74 2d 6e 75 6d 29 0a 3b 3b 3b 20 09 09 09 09 20 t-num).;;; ....
d730: 20 20 20 28 70 69 64 20 20 20 20 20 20 2e 20 2c (pid . ,
d740: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
d750: 2d 69 64 29 29 29 0a 3b 3b 3b 20 09 09 09 09 20 -id))).;;; ....
d760: 20 70 6b 74 73 70 65 63 3a 20 2a 70 6b 74 73 70 pktspec: *pktsp
d770: 65 63 2a 0a 3b 3b 3b 20 09 09 09 09 20 20 70 74 ec*.;;; .... pt
d780: 79 70 65 3a 20 20 20 27 73 65 72 76 65 72 29 29 ype: 'server))
d790: 0a 3b 3b 3b 20 09 09 28 61 72 65 61 2d 70 6b 74 .;;; ..(area-pkt
d7a0: 66 69 6c 65 2d 73 65 74 21 20 61 63 66 67 20 28 file-set! acfg (
d7b0: 63 6f 6e 63 20 70 6b 74 64 69 72 20 22 2f 22 20 conc pktdir "/"
d7c0: 28 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 (area-pktid acfg
d7d0: 29 20 22 2e 70 6b 74 22 29 29 29 29 0a 3b 3b 3b ) ".pkt")))).;;;
d7e0: 20 09 20 20 28 61 72 65 61 2d 70 6f 72 74 2d 73 . (area-port-s
d7f0: 65 74 21 20 20 20 20 61 63 66 67 20 70 6f 72 74 et! acfg port
d800: 2d 6e 75 6d 29 0a 3b 3b 3b 20 09 20 20 23 3b 28 -num).;;; . #;(
d810: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 28 61 mutex-unlock! (a
d820: 72 65 61 2d 6d 75 74 65 78 20 61 63 66 67 29 29 rea-mutex acfg))
d830: 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 )))).;;; .;;; (d
d840: 65 66 69 6e 65 20 2a 63 6f 6f 6b 69 65 2d 73 65 efine *cookie-se
d850: 71 6e 75 6d 2a 20 30 29 0a 3b 3b 3b 20 28 64 65 qnum* 0).;;; (de
d860: 66 69 6e 65 20 28 6d 61 6b 65 2d 63 6f 6f 6b 69 fine (make-cooki
d870: 65 20 6b 65 79 29 0a 3b 3b 3b 20 20 20 28 73 65 e key).;;; (se
d880: 74 21 20 2a 63 6f 6f 6b 69 65 2d 73 65 71 6e 75 t! *cookie-seqnu
d890: 6d 2a 20 28 61 64 64 31 20 2a 63 6f 6f 6b 69 65 m* (add1 *cookie
d8a0: 2d 73 65 71 6e 75 6d 2a 29 29 0a 3b 3b 3b 20 20 -seqnum*)).;;;
d8b0: 20 3b 3b 28 70 72 69 6e 74 20 22 4d 41 4b 45 20 ;;(print "MAKE
d8c0: 43 4f 4f 4b 49 45 20 43 41 4c 4c 45 44 20 2d 2d COOKIE CALLED --
d8d0: 20 6f 6e 20 22 73 65 72 76 6b 65 79 22 2d 22 2a on "servkey"-"*
d8e0: 63 6f 6f 6b 69 65 2d 73 65 71 6e 75 6d 2a 29 0a cookie-seqnum*).
d8f0: 3b 3b 3b 20 20 20 28 63 6f 6e 63 20 6b 65 79 20 ;;; (conc key
d900: 22 2d 22 20 2a 63 6f 6f 6b 69 65 2d 73 65 71 6e "-" *cookie-seqn
d910: 75 6d 2a 29 0a 3b 3b 3b 20 20 20 29 0a 3b 3b 3b um*).;;; ).;;;
d920: 20 0a 3b 3b 3b 20 3b 3b 20 64 69 73 70 61 74 63 .;;; ;; dispatc
d930: 68 20 6c 6f 63 61 6c 6c 79 20 69 66 20 70 6f 73 h locally if pos
d940: 73 69 62 6c 65 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b sible.;;; ;;.;;;
d950: 20 28 64 65 66 69 6e 65 20 28 63 61 6c 6c 2d 64 (define (call-d
d960: 65 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 65 20 eliver-response
d970: 61 63 66 67 20 69 70 61 64 64 72 20 70 6f 72 74 acfg ipaddr port
d980: 20 63 6f 6f 6b 69 65 20 64 61 74 61 29 0a 3b 3b cookie data).;;
d990: 3b 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 ; (if (and (eq
d9a0: 75 61 6c 3f 20 28 61 72 65 61 2d 6d 79 61 64 64 ual? (area-myadd
d9b0: 72 20 61 63 66 67 29 20 69 70 61 64 64 72 29 0a r acfg) ipaddr).
d9c0: 3b 3b 3b 20 09 20 20 20 28 65 71 75 61 6c 3f 20 ;;; . (equal?
d9d0: 28 61 72 65 61 2d 70 6f 72 74 20 20 20 20 20 61 (area-port a
d9e0: 63 66 67 29 20 70 6f 72 74 29 29 0a 3b 3b 3b 20 cfg) port)).;;;
d9f0: 20 20 20 20 20 20 28 64 65 6c 69 76 65 72 2d 72 (deliver-r
da00: 65 73 70 6f 6e 73 65 20 61 63 66 67 20 63 6f 6f esponse acfg coo
da10: 6b 69 65 20 64 61 74 61 29 0a 3b 3b 3b 20 20 20 kie data).;;;
da20: 20 20 20 20 28 28 72 70 63 3a 70 72 6f 63 65 64 ((rpc:proced
da30: 75 72 65 20 27 72 65 73 70 6f 6e 73 65 20 69 70 ure 'response ip
da40: 61 64 64 72 20 70 6f 72 74 29 20 63 6f 6f 6b 69 addr port) cooki
da50: 65 20 64 61 74 61 29 29 29 0a 3b 3b 3b 20 0a 3b e data))).;;; .;
da60: 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 65 6c 69 ;; (define (deli
da70: 76 65 72 2d 72 65 73 70 6f 6e 73 65 20 61 63 66 ver-response acf
da80: 67 20 63 6f 6f 6b 69 65 20 64 61 74 61 29 0a 3b g cookie data).;
da90: 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 65 6c 69 ;; (let ((deli
daa0: 76 65 72 2d 72 65 73 70 6f 6e 73 65 2d 73 74 61 ver-response-sta
dab0: 72 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c rt (current-mill
dac0: 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 iseconds))).;;;
dad0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
dae0: 74 21 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a t! (make-thread.
daf0: 3b 3b 3b 20 09 09 20 20 20 20 28 6c 61 6d 62 64 ;;; .. (lambd
db00: 61 20 28 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 a ().;;; ..
db10: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 72 69 (let loop ((tri
db20: 65 73 2d 6c 65 66 74 20 35 29 29 0a 3b 3b 3b 20 es-left 5)).;;;
db30: 09 09 09 3b 3b 28 70 72 69 6e 74 20 22 54 4f 50 ...;;(print "TOP
db40: 20 4f 46 20 44 45 4c 49 56 45 52 5f 52 45 53 50 OF DELIVER_RESP
db50: 4f 4e 53 45 20 4c 4f 4f 50 3b 20 74 72 69 65 73 ONSE LOOP; tries
db60: 6c 65 66 74 3d 22 74 72 69 65 73 2d 6c 65 66 74 left="tries-left
db70: 29 0a 3b 3b 3b 20 09 09 09 3b 3b 28 70 70 20 28 ).;;; ...;;(pp (
db80: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
db90: 74 20 28 61 72 65 61 2d 63 6f 6f 6b 69 65 32 6d t (area-cookie2m
dba0: 62 6f 78 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 box acfg))).;;;
dbb0: 09 09 09 28 6c 65 74 2a 20 28 28 6d 62 6f 78 20 ...(let* ((mbox
dbc0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
dbd0: 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d 63 6f default (area-co
dbe0: 6f 6b 69 65 32 6d 62 6f 78 20 61 63 66 67 29 20 okie2mbox acfg)
dbf0: 63 6f 6f 6b 69 65 20 23 66 29 29 29 0a 3b 3b 3b cookie #f))).;;;
dc00: 20 09 09 09 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 ... (cond.;;;
dc10: 09 09 09 20 20 20 28 28 65 71 3f 20 30 20 74 72 ... ((eq? 0 tr
dc20: 69 65 73 2d 6c 65 66 74 29 0a 3b 3b 3b 20 09 09 ies-left).;;; ..
dc30: 09 20 20 20 20 28 70 72 69 6e 74 20 22 75 6c 65 . (print "ule
dc40: 78 3a 64 65 6c 69 76 65 72 2d 72 65 73 70 6f 6e x:deliver-respon
dc50: 73 65 3a 20 49 20 67 69 76 65 20 75 70 2e 20 4d se: I give up. M
dc60: 61 69 6c 62 6f 78 20 6e 65 76 65 72 20 61 70 70 ailbox never app
dc70: 65 61 72 65 64 2e 20 63 6f 6f 6b 69 65 3d 22 63 eared. cookie="c
dc80: 6f 6f 6b 69 65 29 0a 3b 3b 3b 20 09 09 09 20 20 ookie).;;; ...
dc90: 20 20 29 0a 3b 3b 3b 20 09 09 09 20 20 20 28 6d ).;;; ... (m
dca0: 62 6f 78 0a 3b 3b 3b 20 09 09 09 20 20 20 20 3b box.;;; ... ;
dcb0: 3b 28 70 72 69 6e 74 20 22 67 6f 74 20 6d 62 6f ;(print "got mbo
dcc0: 78 3d 22 6d 62 6f 78 22 20 20 67 6f 74 20 64 61 x="mbox" got da
dcd0: 74 61 3d 22 64 61 74 61 22 20 20 73 65 6e 64 2e ta="data" send.
dce0: 22 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 28 6d ").;;; ... (m
dcf0: 61 69 6c 62 6f 78 2d 73 65 6e 64 21 20 6d 62 6f ailbox-send! mbo
dd00: 78 20 64 61 74 61 29 29 0a 3b 3b 3b 20 09 09 09 x data)).;;; ...
dd10: 20 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 09 09 (else.;;; ...
dd20: 20 20 20 20 3b 3b 28 70 72 69 6e 74 20 22 6e 6f ;;(print "no
dd30: 20 6d 62 6f 78 20 79 65 74 2e 20 20 6c 6f 6f 6b mbox yet. look
dd40: 20 66 6f 72 20 22 63 6f 6f 6b 69 65 29 0a 3b 3b for "cookie).;;
dd50: 3b 20 09 09 09 20 20 20 20 28 74 68 72 65 61 64 ; ... (thread
dd60: 2d 73 6c 65 65 70 21 20 28 2f 20 28 2d 20 36 20 -sleep! (/ (- 6
dd70: 74 72 69 65 73 2d 6c 65 66 74 29 20 31 30 29 29 tries-left) 10))
dd80: 0a 3b 3b 3b 20 09 09 09 20 20 20 20 28 6c 6f 6f .;;; ... (loo
dd90: 70 20 28 73 75 62 31 20 74 72 69 65 73 2d 6c 65 p (sub1 tries-le
dda0: 66 74 29 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 ft)))))).;;; ..
ddb0: 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 2d 70 ;; (debug-p
ddc0: 70 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 75 p (list (conc "u
ddd0: 6c 65 78 3a 64 65 6c 69 76 65 72 2d 72 65 73 70 lex:deliver-resp
dde0: 6f 6e 73 65 20 74 6f 6f 6b 20 22 20 28 2d 20 28 onse took " (- (
ddf0: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
de00: 6f 6e 64 73 29 20 64 65 6c 69 76 65 72 2d 72 65 onds) deliver-re
de10: 73 70 6f 6e 73 65 2d 73 74 61 72 74 29 20 22 20 sponse-start) "
de20: 6d 73 2c 20 63 6f 6f 6b 69 65 3d 22 20 63 6f 6f ms, cookie=" coo
de30: 6b 69 65 20 22 20 64 61 74 61 3d 22 29 20 64 61 kie " data=") da
de40: 74 61 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 ta)).;;; ..
de50: 20 28 73 64 62 67 3e 20 22 64 65 6c 69 76 65 72 (sdbg> "deliver
de60: 2d 72 65 73 70 6f 6e 73 65 22 20 22 6d 61 69 6c -response" "mail
de70: 62 6f 78 2d 73 65 6e 64 22 20 64 65 6c 69 76 65 box-send" delive
de80: 72 2d 72 65 73 70 6f 6e 73 65 2d 73 74 61 72 74 r-response-start
de90: 20 23 66 20 23 66 20 63 6f 6f 6b 69 65 29 0a 3b #f #f cookie).;
dea0: 3b 3b 20 09 09 20 20 20 20 20 20 29 0a 3b 3b 3b ;; .. ).;;;
deb0: 20 09 09 20 20 20 20 28 63 6f 6e 63 20 22 64 65 .. (conc "de
dec0: 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 65 20 74 liver-response t
ded0: 68 72 65 61 64 20 66 6f 72 20 63 6f 6f 6b 69 65 hread for cookie
dee0: 3d 22 63 6f 6f 6b 69 65 29 29 29 29 0a 3b 3b 3b ="cookie)))).;;;
def0: 20 20 20 23 74 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 #t).;;; .;;;
df00: 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 3b 20 3b ;; action:.;;; ;
df10: 3b 20 20 20 69 6d 6d 65 64 69 61 74 65 20 2d 20 ; immediate -
df20: 71 75 69 63 6b 20 61 63 74 69 6f 6e 73 2c 20 6e quick actions, n
df30: 6f 20 6e 65 65 64 20 74 6f 20 70 75 74 20 69 6e o need to put in
df40: 20 71 75 65 75 65 73 0a 3b 3b 3b 20 3b 3b 20 20 queues.;;; ;;
df50: 20 64 62 77 72 69 74 65 20 20 20 2d 20 70 75 74 dbwrite - put
df60: 20 69 6e 20 64 62 77 72 69 74 65 20 71 75 65 75 in dbwrite queu
df70: 65 0a 3b 3b 3b 20 3b 3b 20 20 20 64 62 72 65 61 e.;;; ;; dbrea
df80: 64 20 20 20 20 2d 20 70 75 74 20 69 6e 20 64 62 d - put in db
df90: 72 65 61 64 20 71 75 65 75 65 0a 3b 3b 3b 20 3b read queue.;;; ;
dfa0: 3b 20 20 20 6f 73 6c 6f 6e 67 20 20 20 20 2d 20 ; oslong -
dfb0: 6f 73 20 61 63 74 69 6f 6e 73 2c 20 65 2e 67 2e os actions, e.g.
dfc0: 20 64 75 2c 20 74 68 61 74 20 63 6f 75 6c 64 20 du, that could
dfd0: 74 61 6b 65 20 61 20 6c 6f 6e 67 20 74 69 6d 65 take a long time
dfe0: 0a 3b 3b 3b 20 3b 3b 20 20 20 6f 73 73 68 6f 72 .;;; ;; osshor
dff0: 74 20 20 20 2d 20 6f 73 20 61 63 74 69 6f 6e 73 t - os actions
e000: 20 74 68 61 74 20 73 68 6f 75 6c 64 20 62 65 20 that should be
e010: 71 75 69 63 6b 2c 20 65 2e 67 2e 20 64 66 0a 3b quick, e.g. df.;
e020: 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e ;; ;;.;;; (defin
e030: 65 20 28 72 65 71 75 65 73 74 20 61 63 66 67 20 e (request acfg
e040: 66 72 6f 6d 2d 69 70 61 64 64 72 20 66 72 6f 6d from-ipaddr from
e050: 2d 70 6f 72 74 20 73 65 72 76 6b 65 79 20 61 63 -port servkey ac
e060: 74 69 6f 6e 20 63 6f 6f 6b 69 65 20 66 6e 61 6d tion cookie fnam
e070: 65 20 70 61 72 61 6d 73 29 20 3b 3b 20 73 74 64 e params) ;; std
e080: 2d 70 65 65 72 2d 68 61 6e 64 6c 65 72 0a 3b 3b -peer-handler.;;
e090: 3b 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 55 73 65 ; ;; NOTE: Use
e0a0: 20 72 70 63 3a 63 75 72 72 65 6e 74 2d 70 65 65 rpc:current-pee
e0b0: 72 20 66 6f 72 20 67 65 74 74 69 6e 67 20 72 65 r for getting re
e0c0: 74 75 72 6e 20 61 64 64 72 65 73 73 0a 3b 3b 3b turn address.;;;
e0d0: 20 20 20 28 6c 65 74 2a 20 28 28 73 74 64 2d 70 (let* ((std-p
e0e0: 65 65 72 2d 68 61 6e 64 6c 65 72 2d 73 74 61 72 eer-handler-star
e0f0: 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 t (current-milli
e100: 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 seconds)).;;; .
e110: 3b 3b 20 28 72 61 77 2d 64 61 74 61 20 20 20 20 ;; (raw-data
e120: 20 20 20 20 20 20 20 20 20 20 20 28 61 6c 69 73 (alis
e130: 74 2d 72 65 66 20 27 64 61 74 61 20 20 20 20 20 t-ref 'data
e140: 64 61 74 29 29 0a 3b 3b 3b 20 09 20 28 72 64 61 dat)).;;; . (rda
e150: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
e160: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
e170: 72 65 66 2f 64 65 66 61 75 6c 74 0a 3b 3b 3b 20 ref/default.;;;
e180: 09 09 09 09 20 20 28 61 72 65 61 2d 72 74 61 62 .... (area-rtab
e190: 6c 65 20 61 63 66 67 29 20 61 63 74 69 6f 6e 20 le acfg) action
e1a0: 23 66 29 29 20 3b 3b 20 74 68 69 73 20 6c 6f 6f #f)) ;; this loo
e1b0: 6b 73 20 75 70 20 74 68 65 20 73 71 6c 20 71 75 ks up the sql qu
e1c0: 65 72 79 20 6f 72 20 6f 74 68 65 72 20 64 65 74 ery or other det
e1d0: 61 69 6c 73 20 69 6e 64 65 78 65 64 20 62 79 20 ails indexed by
e1e0: 74 68 65 20 61 63 74 69 6f 6e 0a 3b 3b 3b 20 09 the action.;;; .
e1f0: 20 28 77 69 74 65 6d 20 20 20 20 20 20 20 20 20 (witem
e200: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 77 (make-w
e210: 69 74 65 6d 20 72 69 70 61 64 64 72 3a 20 66 72 item ripaddr: fr
e220: 6f 6d 2d 69 70 61 64 64 72 20 3b 3b 20 72 68 6f om-ipaddr ;; rho
e230: 73 74 3a 20 20 20 66 72 6f 6d 2d 68 6f 73 74 20 st: from-host
e240: 20 20 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 .;;; .....
e250: 20 72 70 6f 72 74 3a 20 20 20 66 72 6f 6d 2d 70 rport: from-p
e260: 6f 72 74 20 20 20 61 63 74 69 6f 6e 3a 20 20 61 ort action: a
e270: 63 74 69 6f 6e 0a 3b 3b 3b 20 09 09 09 09 09 20 ction.;;; .....
e280: 20 20 20 20 72 64 61 74 3a 20 20 20 20 72 64 61 rdat: rda
e290: 74 20 20 20 20 20 20 20 20 63 6f 6f 6b 69 65 3a t cookie:
e2a0: 20 20 63 6f 6f 6b 69 65 0a 3b 3b 3b 20 09 09 09 cookie.;;; ...
e2b0: 09 09 20 20 20 20 20 73 65 72 76 6b 65 79 3a 20 .. servkey:
e2c0: 73 65 72 76 6b 65 79 20 20 20 20 20 64 61 74 61 servkey data
e2d0: 3a 20 20 20 20 70 61 72 61 6d 73 20 3b 3b 20 54 : params ;; T
e2e0: 4f 44 4f 20 2d 20 72 65 6e 61 6d 65 20 64 61 74 ODO - rename dat
e2f0: 61 20 74 6f 20 70 61 72 61 6d 73 0a 3b 3b 3b 20 a to params.;;;
e300: 09 09 09 09 09 20 20 20 20 20 63 61 6c 6c 65 72 ..... caller
e310: 3a 20 20 28 72 70 63 3a 63 75 72 72 65 6e 74 2d : (rpc:current-
e320: 70 65 65 72 29 29 29 29 0a 3b 3b 3b 20 20 20 20 peer)))).;;;
e330: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c (if (not (equal
e340: 3f 20 73 65 72 76 6b 65 79 20 28 61 72 65 61 2d ? servkey (area-
e350: 70 6b 74 69 64 20 61 63 66 67 29 29 29 0a 3b 3b pktid acfg))).;;
e360: 3b 20 09 60 28 23 66 20 2e 20 2c 28 63 6f 6e 63 ; .`(#f . ,(conc
e370: 20 22 49 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 79 "I don't know y
e380: 6f 75 20 73 65 72 76 6b 65 79 3d 22 20 73 65 72 ou servkey=" ser
e390: 76 6b 65 79 20 22 2c 20 70 6b 74 69 64 3d 22 20 vkey ", pktid="
e3a0: 28 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 (area-pktid acfg
e3b0: 29 29 29 20 3b 3b 20 69 6d 6d 65 64 69 61 74 65 ))) ;; immediate
e3c0: 6c 79 20 72 65 74 75 72 6e 20 74 68 69 73 0a 3b ly return this.;
e3d0: 3b 3b 20 09 28 6c 65 74 2a 20 28 28 63 74 79 70 ;; .(let* ((ctyp
e3e0: 65 20 28 69 66 20 72 64 61 74 20 0a 3b 3b 3b 20 e (if rdat .;;;
e3f0: 09 09 09 20 20 28 63 61 6c 6c 64 61 74 2d 63 74 ... (calldat-ct
e400: 79 70 65 20 72 64 61 74 29 20 3b 3b 20 69 73 20 ype rdat) ;; is
e410: 74 68 69 73 20 6e 65 63 65 73 73 61 72 79 3f 20 this necessary?
e420: 74 68 65 73 65 20 73 68 6f 75 6c 64 20 62 65 20 these should be
e430: 69 64 65 6e 74 69 63 61 6c 0a 3b 3b 3b 20 09 09 identical.;;; ..
e440: 09 20 20 61 63 74 69 6f 6e 29 29 29 0a 3b 3b 3b . action))).;;;
e450: 20 09 20 20 28 73 64 62 67 3e 20 22 73 74 64 2d . (sdbg> "std-
e460: 70 65 65 72 2d 68 61 6e 64 6c 65 72 22 20 22 69 peer-handler" "i
e470: 6d 6d 65 64 69 61 74 65 22 20 73 74 64 2d 70 65 mmediate" std-pe
e480: 65 72 2d 68 61 6e 64 6c 65 72 2d 73 74 61 72 74 er-handler-start
e490: 20 23 66 20 23 66 29 0a 3b 3b 3b 20 09 20 20 28 #f #f).;;; . (
e4a0: 63 61 73 65 20 63 74 79 70 65 0a 3b 3b 3b 20 09 case ctype.;;; .
e4b0: 20 20 20 20 3b 3b 20 28 64 62 77 72 69 74 65 20 ;; (dbwrite
e4c0: 61 63 66 67 20 72 64 61 74 20 28 63 6f 6e 73 20 acfg rdat (cons
e4d0: 66 72 6f 6d 2d 69 70 61 64 64 72 20 66 72 6f 6d from-ipaddr from
e4e0: 2d 70 6f 72 74 29 20 64 61 74 61 29 29 29 0a 3b -port) data))).;
e4f0: 3b 3b 20 09 20 20 20 20 28 28 66 75 6c 6c 2d 70 ;; . ((full-p
e500: 69 6e 67 29 20 20 60 28 23 74 20 20 22 61 63 6b ing) `(#t "ack
e510: 20 74 6f 20 66 75 6c 6c 20 70 69 6e 67 22 20 20 to full ping"
e520: 20 20 20 20 20 20 2c 28 77 6f 72 6b 2d 71 75 65 ,(work-que
e530: 75 65 2d 61 64 64 20 61 63 66 67 20 66 6e 61 6d ue-add acfg fnam
e540: 65 20 77 69 74 65 6d 29 20 2c 63 6f 6f 6b 69 65 e witem) ,cookie
e550: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 28 72 65 )).;;; . ((re
e560: 73 70 6f 6e 73 65 29 20 20 20 60 28 23 74 20 20 sponse) `(#t
e570: 22 61 63 6b 20 66 72 6f 6d 20 72 65 71 75 65 73 "ack from reques
e580: 74 6f 72 22 20 20 20 20 20 20 2c 28 64 65 6c 69 tor" ,(deli
e590: 76 65 72 2d 72 65 73 70 6f 6e 73 65 20 61 63 66 ver-response acf
e5a0: 67 20 66 6e 61 6d 65 20 70 61 72 61 6d 73 29 29 g fname params))
e5b0: 29 0a 3b 3b 3b 20 09 20 20 20 20 28 28 64 62 77 ).;;; . ((dbw
e5c0: 72 69 74 65 29 20 20 20 20 60 28 23 74 20 20 22 rite) `(#t "
e5d0: 64 62 20 77 72 69 74 65 20 73 75 62 6d 69 74 74 db write submitt
e5e0: 65 64 22 20 20 20 20 20 20 2c 28 77 6f 72 6b 2d ed" ,(work-
e5f0: 71 75 65 75 65 2d 61 64 64 20 61 63 66 67 20 66 queue-add acfg f
e600: 6e 61 6d 65 20 77 69 74 65 6d 29 20 2c 63 6f 6f name witem) ,coo
e610: 6b 69 65 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 kie)).;;; . (
e620: 28 64 62 72 65 61 64 29 20 20 20 20 20 60 28 23 (dbread) `(#
e630: 74 20 20 22 64 62 20 72 65 61 64 20 73 75 62 6d t "db read subm
e640: 69 74 74 65 64 22 20 20 20 20 20 20 20 2c 28 77 itted" ,(w
e650: 6f 72 6b 2d 71 75 65 75 65 2d 61 64 64 20 61 63 ork-queue-add ac
e660: 66 67 20 66 6e 61 6d 65 20 77 69 74 65 6d 29 20 fg fname witem)
e670: 2c 63 6f 6f 6b 69 65 20 20 29 29 0a 3b 3b 3b 20 ,cookie )).;;;
e680: 09 20 20 20 20 28 28 64 62 72 77 29 20 20 20 20 . ((dbrw)
e690: 20 20 20 60 28 23 74 20 20 22 64 62 20 72 65 61 `(#t "db rea
e6a0: 64 2f 77 72 69 74 65 20 73 75 62 6d 69 74 74 65 d/write submitte
e6b0: 64 22 20 2c 63 6f 6f 6b 69 65 29 29 0a 3b 3b 3b d" ,cookie)).;;;
e6c0: 20 09 20 20 20 20 28 28 6f 73 73 68 6f 72 74 29 . ((osshort)
e6d0: 20 20 20 20 60 28 23 74 20 20 22 6f 73 20 73 68 `(#t "os sh
e6e0: 6f 72 74 20 73 75 62 6d 69 74 74 65 64 22 20 20 ort submitted"
e6f0: 20 20 20 20 2c 63 6f 6f 6b 69 65 29 29 0a 3b 3b ,cookie)).;;
e700: 3b 20 09 20 20 20 20 28 28 6f 73 6c 6f 6e 67 29 ; . ((oslong)
e710: 20 20 20 20 20 60 28 23 74 20 20 22 6f 73 20 6c `(#t "os l
e720: 6f 6e 67 20 73 75 62 6d 69 74 74 65 64 22 20 20 ong submitted"
e730: 20 20 20 20 20 2c 63 6f 6f 6b 69 65 29 29 0a 3b ,cookie)).;
e740: 3b 3b 20 09 20 20 20 20 28 65 6c 73 65 20 20 20 ;; . (else
e750: 20 20 20 20 20 20 60 28 23 66 20 20 22 75 6e 72 `(#f "unr
e760: 65 63 6f 67 6e 69 73 65 64 20 61 63 74 69 6f 6e ecognised action
e770: 22 20 20 20 20 20 2c 63 74 79 70 65 29 29 29 29 " ,ctype))))
e780: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 ))).;;; .;;; ;;
e790: 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 73 74 61 Call this to sta
e7a0: 72 74 20 74 68 65 20 61 63 74 75 61 6c 20 73 65 rt the actual se
e7b0: 72 76 65 72 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 rver.;;; ;;.;;;
e7c0: 3b 3b 20 73 74 61 72 74 5f 73 65 72 76 65 72 0a ;; start_server.
e7d0: 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 20 20 ;;; ;;.;;; ;;
e7e0: 6d 6f 64 65 3a 20 27 0a 3b 3b 3b 20 3b 3b 20 20 mode: '.;;; ;;
e7f0: 20 68 61 6e 64 6c 65 72 3a 20 70 72 6f 63 20 77 handler: proc w
e800: 68 69 63 68 20 74 61 6b 65 73 20 70 6b 74 72 65 hich takes pktre
e810: 63 69 65 76 65 64 20 61 73 20 61 72 67 75 6d 65 cieved as argume
e820: 6e 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 0a 3b nt.;;; ;;.;;; .;
e830: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 74 61 72 ;; (define (star
e840: 74 2d 73 65 72 76 65 72 20 61 63 66 67 29 0a 3b t-server acfg).;
e850: 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e ;; (let* ((con
e860: 6e 20 28 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 n (find-free-por
e870: 74 2d 61 6e 64 2d 6f 70 65 6e 20 61 63 66 67 29 t-and-open acfg)
e880: 29 0a 3b 3b 3b 20 09 20 28 70 6f 72 74 20 28 61 ).;;; . (port (a
e890: 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 29 29 rea-port acfg)))
e8a0: 0a 3b 3b 3b 20 20 20 20 20 28 72 70 63 3a 70 75 .;;; (rpc:pu
e8b0: 62 6c 69 73 68 2d 70 72 6f 63 65 64 75 72 65 21 blish-procedure!
e8c0: 0a 3b 3b 3b 20 20 20 20 20 20 27 64 65 6c 69 73 .;;; 'delis
e8d0: 74 2d 64 62 0a 3b 3b 3b 20 20 20 20 20 20 28 6c t-db.;;; (l
e8e0: 61 6d 62 64 61 20 28 66 6e 61 6d 65 29 0a 3b 3b ambda (fname).;;
e8f0: 3b 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 ; (hash-t
e900: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 61 72 able-delete! (ar
e910: 65 61 2d 64 62 73 20 61 63 66 67 29 20 66 6e 61 ea-dbs acfg) fna
e920: 6d 65 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 me))).;;; (r
e930: 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 pc:publish-proce
e940: 64 75 72 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 dure!.;;; '
e950: 63 61 6c 6c 69 6e 67 2d 61 64 64 72 0a 3b 3b 3b calling-addr.;;;
e960: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
e970: 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 72 70 63 .;;; (rpc
e980: 3a 63 75 72 72 65 6e 74 2d 70 65 65 72 29 29 29 :current-peer)))
e990: 0a 3b 3b 3b 20 20 20 20 20 28 72 70 63 3a 70 75 .;;; (rpc:pu
e9a0: 62 6c 69 73 68 2d 70 72 6f 63 65 64 75 72 65 21 blish-procedure!
e9b0: 0a 3b 3b 3b 20 20 20 20 20 20 27 70 69 6e 67 0a .;;; 'ping.
e9c0: 3b 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ;;; (lambda
e9d0: 20 28 29 28 72 65 61 6c 2d 70 69 6e 67 20 61 63 ()(real-ping ac
e9e0: 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 fg))).;;; (r
e9f0: 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 pc:publish-proce
ea00: 64 75 72 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 dure!.;;; '
ea10: 72 65 71 75 65 73 74 0a 3b 3b 3b 20 20 20 20 20 request.;;;
ea20: 20 28 6c 61 6d 62 64 61 20 28 66 72 6f 6d 2d 61 (lambda (from-a
ea30: 64 64 72 20 66 72 6f 6d 2d 70 6f 72 74 20 73 65 ddr from-port se
ea40: 72 76 6b 65 79 20 61 63 74 69 6f 6e 20 63 6f 6f rvkey action coo
ea50: 6b 69 65 20 64 62 6e 61 6d 65 20 70 61 72 61 6d kie dbname param
ea60: 73 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 72 s).;;; (r
ea70: 65 71 75 65 73 74 20 61 63 66 67 20 66 72 6f 6d equest acfg from
ea80: 2d 61 64 64 72 20 66 72 6f 6d 2d 70 6f 72 74 20 -addr from-port
ea90: 73 65 72 76 6b 65 79 20 61 63 74 69 6f 6e 20 63 servkey action c
eaa0: 6f 6f 6b 69 65 20 64 62 6e 61 6d 65 20 70 61 72 ookie dbname par
eab0: 61 6d 73 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 ams))).;;; (
eac0: 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 rpc:publish-proc
ead0: 65 64 75 72 65 21 0a 3b 3b 3b 20 20 20 20 20 20 edure!.;;;
eae0: 27 72 65 73 70 6f 6e 73 65 0a 3b 3b 3b 20 20 20 'response.;;;
eaf0: 20 20 20 28 6c 61 6d 62 64 61 20 28 63 6f 6f 6b (lambda (cook
eb00: 69 65 20 72 65 73 2d 64 61 74 29 0a 3b 3b 3b 20 ie res-dat).;;;
eb10: 20 20 20 20 20 20 20 28 64 65 6c 69 76 65 72 2d (deliver-
eb20: 72 65 73 70 6f 6e 73 65 20 61 63 66 67 20 63 6f response acfg co
eb30: 6f 6b 69 65 20 72 65 73 2d 64 61 74 29 29 29 0a okie res-dat))).
eb40: 3b 3b 3b 20 20 20 20 20 28 61 72 65 61 2d 72 65 ;;; (area-re
eb50: 61 64 79 2d 73 65 74 21 20 61 63 66 67 20 23 74 ady-set! acfg #t
eb60: 29 0a 3b 3b 3b 20 20 20 20 20 28 61 72 65 61 2d ).;;; (area-
eb70: 63 6f 6e 6e 2d 73 65 74 21 20 61 63 66 67 20 63 conn-set! acfg c
eb80: 6f 6e 6e 29 0a 3b 3b 3b 20 20 20 20 20 28 28 72 onn).;;; ((r
eb90: 70 63 3a 6d 61 6b 65 2d 73 65 72 76 65 72 20 63 pc:make-server c
eba0: 6f 6e 6e 29 20 23 66 29 29 29 3b 3b 20 28 28 74 onn) #f)));; ((t
ebb0: 63 70 2d 6c 69 73 74 65 6e 20 28 72 70 63 3a 64 cp-listen (rpc:d
ebc0: 65 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f efault-server-po
ebd0: 72 74 29 29 20 23 74 29 0a 3b 3b 3b 20 0a 3b 3b rt)) #t).;;; .;;
ebe0: 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ; .;;; (define (
ebf0: 6c 61 75 6e 63 68 20 61 63 66 67 29 20 3b 3b 20 launch acfg) ;;
ec00: 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 70 72 6f #!optional (pro
ec10: 63 20 73 74 64 2d 70 65 65 72 2d 68 61 6e 64 6c c std-peer-handl
ec20: 65 72 29 29 0a 3b 3b 3b 20 20 20 28 70 72 69 6e er)).;;; (prin
ec30: 74 20 22 73 74 61 72 74 69 6e 67 20 6c 61 75 6e t "starting laun
ec40: 63 68 22 29 0a 3b 3b 3b 20 20 20 28 75 70 64 61 ch").;;; (upda
ec50: 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 te-known-servers
ec60: 20 61 63 66 67 29 20 3b 3b 20 67 6f 74 74 61 20 acfg) ;; gotta
ec70: 64 6f 20 74 68 69 73 20 6f 6e 20 65 76 65 72 79 do this on every
ec80: 20 73 74 61 72 74 20 28 74 68 75 73 20 77 68 79 start (thus why
ec90: 20 6c 69 6d 69 74 20 6e 75 6d 62 65 72 20 6f 66 limit number of
eca0: 20 70 75 62 6c 69 63 69 73 65 64 20 73 65 72 76 publicised serv
ecb0: 65 72 73 29 0a 3b 3b 3b 20 20 20 23 3b 28 6c 65 ers).;;; #;(le
ecc0: 74 20 28 28 6f 72 69 67 69 6e 61 6c 2d 68 61 6e t ((original-han
ecd0: 64 6c 65 72 20 28 63 75 72 72 65 6e 74 2d 65 78 dler (current-ex
ece0: 63 65 70 74 69 6f 6e 2d 68 61 6e 64 6c 65 72 29 ception-handler)
ecf0: 29 29 20 3b 3b 20 69 73 20 74 68 0a 3b 3b 3b 20 )) ;; is th.;;;
ed00: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 65 78 63 (lambda (exc
ed10: 65 70 74 69 6f 6e 29 0a 3b 3b 3b 20 20 20 20 20 eption).;;;
ed20: 20 20 28 73 65 72 76 65 72 2d 65 78 69 74 2d 70 (server-exit-p
ed30: 72 6f 63 65 64 75 72 65 29 0a 3b 3b 3b 20 20 20 rocedure).;;;
ed40: 20 20 20 20 28 6f 72 69 67 69 6e 61 6c 2d 68 61 (original-ha
ed50: 6e 64 6c 65 72 20 65 78 63 65 70 74 69 6f 6e 29 ndler exception)
ed60: 29 29 0a 3b 3b 3b 20 20 20 28 6f 6e 2d 65 78 69 )).;;; (on-exi
ed70: 74 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b t (lambda ().;;;
ed80: 20 09 20 20 20 20 20 28 73 68 75 74 64 6f 77 6e . (shutdown
ed90: 20 61 63 66 67 29 29 29 20 3b 3b 20 28 66 69 6e acfg))) ;; (fin
eda0: 61 6c 69 7a 65 2d 61 6c 6c 2d 64 62 2d 68 61 6e alize-all-db-han
edb0: 64 6c 65 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b dles acfg))).;;;
edc0: 20 20 20 3b 3b 20 73 65 74 20 75 70 20 74 68 65 ;; set up the
edd0: 20 72 70 63 20 68 61 6e 64 6c 65 72 0a 3b 3b 3b rpc handler.;;;
ede0: 20 20 20 28 6c 65 74 2a 20 28 28 74 68 31 20 20 (let* ((th1
edf0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 3b 3b 3b (make-thread.;;;
ee00: 20 09 09 28 6c 61 6d 62 64 61 20 28 29 28 73 74 ..(lambda ()(st
ee10: 61 72 74 2d 73 65 72 76 65 72 20 61 63 66 67 29 art-server acfg)
ee20: 29 0a 3b 3b 3b 20 09 09 22 73 65 72 76 65 72 20 ).;;; .."server
ee30: 74 68 72 65 61 64 22 29 29 0a 3b 3b 3b 20 09 20 thread")).;;; .
ee40: 28 74 68 32 20 20 20 28 6d 61 6b 65 2d 74 68 72 (th2 (make-thr
ee50: 65 61 64 0a 3b 3b 3b 20 09 09 20 28 6c 61 6d 62 ead.;;; .. (lamb
ee60: 64 61 20 28 29 0a 3b 3b 3b 20 09 09 20 20 20 28 da ().;;; .. (
ee70: 70 72 69 6e 74 20 22 74 68 32 20 73 74 61 72 74 print "th2 start
ee80: 69 6e 67 22 29 0a 3b 3b 3b 20 09 09 20 20 20 28 ing").;;; .. (
ee90: 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 3b 3b 3b 20 let loop ().;;;
eea0: 09 09 20 20 20 20 20 28 77 6f 72 6b 2d 71 75 65 .. (work-que
eeb0: 75 65 2d 70 72 6f 63 65 73 73 6f 72 20 61 63 66 ue-processor acf
eec0: 67 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 70 g).;;; .. (p
eed0: 72 69 6e 74 20 22 77 6f 72 6b 2d 71 75 65 75 65 rint "work-queue
eee0: 2d 70 72 6f 63 65 73 73 6f 72 20 63 72 61 73 68 -processor crash
eef0: 65 64 21 22 29 0a 3b 3b 3b 20 09 09 20 20 20 20 ed!").;;; ..
ef00: 20 28 6c 6f 6f 70 29 29 29 0a 3b 3b 3b 20 09 09 (loop))).;;; ..
ef10: 20 22 77 6f 72 6b 20 71 75 65 75 65 20 74 68 72 "work queue thr
ef20: 65 61 64 22 29 29 29 0a 3b 3b 3b 20 20 20 20 20 ead"))).;;;
ef30: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
ef40: 68 31 29 0a 3b 3b 3b 20 20 20 20 20 28 74 68 72 h1).;;; (thr
ef50: 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a ead-start! th2).
ef60: 3b 3b 3b 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ;;; (let loo
ef70: 70 20 28 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 p ().;;; (
ef80: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
ef90: 30 32 35 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 025).;;; (
efa0: 69 66 20 28 61 72 65 61 2d 72 65 61 64 79 20 61 if (area-ready a
efb0: 63 66 67 29 0a 3b 3b 3b 20 09 20 20 23 74 0a 3b cfg).;;; . #t.;
efc0: 3b 3b 20 09 20 20 28 6c 6f 6f 70 29 29 29 0a 3b ;; . (loop))).;
efd0: 3b 3b 20 20 20 20 20 3b 3b 20 61 74 74 65 6d 70 ;; ;; attemp
efe0: 74 20 74 6f 20 66 69 78 20 6d 79 20 61 64 64 72 t to fix my addr
eff0: 65 73 73 0a 3b 3b 3b 20 20 20 20 20 28 6c 65 74 ess.;;; (let
f000: 2a 20 28 28 61 6c 6c 2d 61 64 64 72 20 28 67 65 * ((all-addr (ge
f010: 74 2d 61 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 t-all-ips-sorted
f020: 29 29 29 09 20 20 20 20 20 3b 3b 20 63 6f 75 6c ))). ;; coul
f030: 64 20 75 73 65 20 28 74 63 70 2d 61 64 64 72 65 d use (tcp-addre
f040: 73 73 65 73 20 63 6f 6e 6e 29 3f 0a 3b 3b 3b 20 sses conn)?.;;;
f050: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
f060: 28 28 72 65 6d 2d 61 64 64 72 73 20 61 6c 6c 2d ((rem-addrs all-
f070: 61 64 64 72 29 29 0a 3b 3b 3b 20 09 28 69 66 20 addr)).;;; .(if
f080: 28 6e 75 6c 6c 3f 20 72 65 6d 2d 61 64 64 72 73 (null? rem-addrs
f090: 29 0a 3b 3b 3b 20 09 20 20 20 20 28 62 65 67 69 ).;;; . (begi
f0a0: 6e 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 70 72 n.;;; . (pr
f0b0: 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c int "ERROR: Fail
f0c0: 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 ed to figure out
f0d0: 20 74 68 65 20 69 70 20 61 64 64 72 65 73 73 20 the ip address
f0e0: 6f 66 20 6d 79 73 65 6c 66 20 61 73 20 61 20 73 of myself as a s
f0f0: 65 72 76 65 72 2e 20 47 69 76 69 6e 67 20 75 70 erver. Giving up
f100: 2e 22 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 .").;;; . (
f110: 65 78 69 74 20 31 29 29 20 3b 3b 20 42 55 47 20 exit 1)) ;; BUG
f120: 43 68 61 6e 67 65 6d 65 20 74 6f 20 72 61 69 73 Changeme to rais
f130: 69 6e 67 20 61 6e 20 65 78 63 65 70 74 69 6f 6e ing an exception
f140: 0a 3b 3b 3b 20 09 09 0a 3b 3b 3b 20 09 20 20 20 .;;; ...;;; .
f150: 20 28 6c 65 74 2a 20 28 28 61 64 64 72 20 20 20 (let* ((addr
f160: 20 20 20 28 63 61 72 20 72 65 6d 2d 61 64 64 72 (car rem-addr
f170: 73 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 67 6f s)).;;; .. (go
f180: 6f 64 2d 61 64 64 72 20 28 68 61 6e 64 6c 65 2d od-addr (handle-
f190: 65 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 3b 20 09 exceptions.;;; .
f1a0: 09 09 09 20 20 65 78 6e 0a 3b 3b 3b 20 09 09 09 ... exn.;;; ...
f1b0: 09 20 20 23 66 0a 3b 3b 3b 20 09 09 09 09 28 28 . #f.;;; ....((
f1c0: 72 70 63 3a 70 72 6f 63 65 64 75 72 65 20 27 63 rpc:procedure 'c
f1d0: 61 6c 6c 69 6e 67 2d 61 64 64 72 20 61 64 64 72 alling-addr addr
f1e0: 20 28 61 72 65 61 2d 70 6f 72 74 20 61 63 66 67 (area-port acfg
f1f0: 29 29 29 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 )))))).;;; .
f200: 20 20 28 69 66 20 67 6f 6f 64 2d 61 64 64 72 0a (if good-addr.
f210: 3b 3b 3b 20 09 09 20 20 28 62 65 67 69 6e 0a 3b ;;; .. (begin.;
f220: 3b 3b 20 09 09 20 20 20 20 28 70 72 69 6e 74 20 ;; .. (print
f230: 22 47 6f 74 20 67 6f 6f 64 2d 61 64 64 72 20 6f "Got good-addr o
f240: 66 20 22 20 67 6f 6f 64 2d 61 64 64 72 29 0a 3b f " good-addr).;
f250: 3b 3b 20 09 09 20 20 20 20 28 61 72 65 61 2d 6d ;; .. (area-m
f260: 79 61 64 64 72 2d 73 65 74 21 20 61 63 66 67 20 yaddr-set! acfg
f270: 67 6f 6f 64 2d 61 64 64 72 29 29 0a 3b 3b 3b 20 good-addr)).;;;
f280: 09 09 20 20 28 6c 6f 6f 70 20 28 63 64 72 20 72 .. (loop (cdr r
f290: 65 6d 2d 61 64 64 72 73 29 29 29 29 29 29 29 0a em-addrs))))))).
f2a0: 3b 3b 3b 20 20 20 20 20 28 72 65 67 69 73 74 65 ;;; (registe
f2b0: 72 2d 6e 6f 64 65 20 61 63 66 67 20 28 61 72 65 r-node acfg (are
f2c0: 61 2d 6d 79 61 64 64 72 20 61 63 66 67 29 28 61 a-myaddr acfg)(a
f2d0: 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 29 0a rea-port acfg)).
f2e0: 3b 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 ;;; (print "
f2f0: 49 4e 46 4f 3a 20 53 65 72 76 65 72 20 73 74 61 INFO: Server sta
f300: 72 74 65 64 20 6f 6e 20 22 20 28 61 72 65 61 2d rted on " (area-
f310: 6d 79 61 64 64 72 20 61 63 66 67 29 20 22 3a 22 myaddr acfg) ":"
f320: 20 28 61 72 65 61 2d 70 6f 72 74 20 61 63 66 67 (area-port acfg
f330: 29 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 28 75 )).;;; ;; (u
f340: 70 64 61 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 pdate-known-serv
f350: 65 72 73 20 61 63 66 67 29 20 3b 3b 20 67 6f 74 ers acfg) ;; got
f360: 74 61 20 64 6f 20 74 68 69 73 20 6f 6e 20 65 76 ta do this on ev
f370: 65 72 79 20 73 74 61 72 74 20 28 74 68 75 73 20 ery start (thus
f380: 77 68 79 20 6c 69 6d 69 74 20 6e 75 6d 62 65 72 why limit number
f390: 20 6f 66 20 70 75 62 6c 69 63 69 73 65 64 20 73 of publicised s
f3a0: 65 72 76 65 72 73 29 0a 3b 3b 3b 20 20 20 20 20 ervers).;;;
f3b0: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 )).;;; .;;; (def
f3c0: 69 6e 65 20 28 63 6c 65 61 72 2d 73 65 72 76 65 ine (clear-serve
f3d0: 72 2d 70 6b 74 20 61 63 66 67 29 0a 3b 3b 3b 20 r-pkt acfg).;;;
f3e0: 20 20 28 6c 65 74 20 28 28 70 6b 74 66 20 28 61 (let ((pktf (a
f3f0: 72 65 61 2d 70 6b 74 66 69 6c 65 20 61 63 66 67 rea-pktfile acfg
f400: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 ))).;;; (if
f410: 70 6b 74 66 20 28 64 65 6c 65 74 65 2d 66 69 6c pktf (delete-fil
f420: 65 2a 20 70 6b 74 66 29 29 29 29 0a 3b 3b 3b 20 e* pktf)))).;;;
f430: 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 68 .;;; (define (sh
f440: 75 74 64 6f 77 6e 20 61 63 66 67 29 0a 3b 3b 3b utdown acfg).;;;
f450: 20 20 20 28 6c 65 74 20 28 3b 3b 28 63 6f 6e 6e (let (;;(conn
f460: 20 28 61 72 65 61 2d 63 6f 6e 6e 20 20 20 20 61 (area-conn a
f470: 63 66 67 29 29 0a 3b 3b 3b 20 09 28 70 6b 74 66 cfg)).;;; .(pktf
f480: 20 28 61 72 65 61 2d 70 6b 74 66 69 6c 65 20 61 (area-pktfile a
f490: 63 66 67 29 29 0a 3b 3b 3b 20 09 28 70 6f 72 74 cfg)).;;; .(port
f4a0: 20 28 61 72 65 61 2d 70 6f 72 74 20 20 20 20 61 (area-port a
f4b0: 63 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 cfg))).;;; (
f4c0: 69 66 20 70 6b 74 66 20 28 64 65 6c 65 74 65 2d if pktf (delete-
f4d0: 66 69 6c 65 2a 20 70 6b 74 66 29 29 0a 3b 3b 3b file* pktf)).;;;
f4e0: 20 20 20 20 20 28 73 65 6e 64 2d 61 6c 6c 20 22 (send-all "
f4f0: 69 6d 73 68 75 74 74 69 6e 67 64 6f 77 6e 22 29 imshuttingdown")
f500: 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 28 72 70 63 .;;; ;; (rpc
f510: 3a 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 :close-all-conne
f520: 63 74 69 6f 6e 73 21 29 20 3b 3b 20 64 6f 6e 27 ctions!) ;; don'
f530: 74 20 6b 6e 6f 77 20 69 66 20 74 68 69 73 20 69 t know if this i
f540: 73 20 61 63 74 75 61 6c 6c 79 20 6e 65 65 64 65 s actually neede
f550: 64 0a 3b 3b 3b 20 20 20 20 20 28 66 69 6e 61 6c d.;;; (final
f560: 69 7a 65 2d 61 6c 6c 2d 64 62 2d 68 61 6e 64 6c ize-all-db-handl
f570: 65 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 0a es acfg))).;;; .
f580: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 6e ;;; (define (sen
f590: 64 2d 61 6c 6c 20 6d 73 67 29 0a 3b 3b 3b 20 20 d-all msg).;;;
f5a0: 20 23 66 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b #f).;;; .;;; ;;
f5b0: 20 67 69 76 65 6e 20 61 20 61 72 65 61 20 72 65 given a area re
f5c0: 63 6f 72 64 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c cord look up all
f5d0: 20 74 68 65 20 70 61 63 6b 65 74 73 0a 3b 3b 3b the packets.;;;
f5e0: 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 ;;.;;; (define
f5f0: 28 67 65 74 2d 61 6c 6c 2d 73 65 72 76 65 72 2d (get-all-server-
f600: 70 6b 74 73 20 61 63 66 67 29 0a 3b 3b 3b 20 20 pkts acfg).;;;
f610: 20 28 6c 65 74 20 28 28 61 6c 6c 2d 70 6b 74 2d (let ((all-pkt-
f620: 66 69 6c 65 73 20 28 67 6c 6f 62 20 28 63 6f 6e files (glob (con
f630: 63 20 28 61 72 65 61 2d 70 6b 74 73 64 69 72 20 c (area-pktsdir
f640: 61 63 66 67 29 20 22 2f 2a 2e 70 6b 74 22 29 29 acfg) "/*.pkt"))
f650: 29 29 0a 3b 3b 3b 20 20 20 20 20 28 6d 61 70 20 )).;;; (map
f660: 28 6c 61 6d 62 64 61 20 28 70 6b 74 2d 66 69 6c (lambda (pkt-fil
f670: 65 29 0a 3b 3b 3b 20 09 20 20 20 28 72 65 61 64 e).;;; . (read
f680: 2d 70 6b 74 2d 3e 61 6c 69 73 74 20 70 6b 74 2d -pkt->alist pkt-
f690: 66 69 6c 65 20 70 6b 74 73 70 65 63 3a 20 2a 70 file pktspec: *p
f6a0: 6b 74 73 70 65 63 2a 29 29 0a 3b 3b 3b 20 09 20 ktspec*)).;;; .
f6b0: 61 6c 6c 2d 70 6b 74 2d 66 69 6c 65 73 29 29 29 all-pkt-files)))
f6c0: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 23 3b 28 28 5a 20 .;;; .;;; #;((Z
f6d0: 2e 20 22 39 61 30 32 31 32 33 30 32 32 39 35 61 . "9a0212302295a
f6e0: 31 39 36 31 30 64 35 37 39 36 66 63 65 30 33 37 19610d5796fce037
f6f0: 30 66 61 31 33 30 37 35 38 65 39 22 29 0a 3b 3b 0fa130758e9").;;
f700: 3b 20 20 20 28 70 6f 72 74 20 2e 20 22 33 34 38 ; (port . "348
f710: 32 37 22 29 0a 3b 3b 3b 20 20 20 28 70 69 64 20 27").;;; (pid
f720: 2e 20 22 32 38 37 34 38 22 29 0a 3b 3b 3b 20 20 . "28748").;;;
f730: 20 28 68 6f 73 74 6e 61 6d 65 20 2e 20 22 7a 65 (hostname . "ze
f740: 75 73 22 29 0a 3b 3b 3b 20 20 20 28 54 20 2e 20 us").;;; (T .
f750: 22 73 65 72 76 65 72 22 29 0a 3b 3b 3b 20 20 20 "server").;;;
f760: 28 44 20 2e 20 22 31 35 34 39 34 32 37 30 33 32 (D . "1549427032
f770: 2e 30 22 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 23 .0")).;;; .;;; #
f780: 3b 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6d 79 ;(define (get-my
f790: 2d 62 65 73 74 2d 61 64 64 72 65 73 73 29 0a 3b -best-address).;
f7a0: 3b 3b 20 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d ;; (let ((all-
f7b0: 6d 79 2d 61 64 64 72 65 73 73 65 73 20 28 67 65 my-addresses (ge
f7c0: 74 2d 61 6c 6c 2d 69 70 73 29 29 29 20 3b 3b 20 t-all-ips))) ;;
f7d0: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 (vector->list (h
f7e0: 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 ostinfo-addresse
f7f0: 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 s (hostname->hos
f800: 74 69 6e 66 6f 20 28 67 65 74 2d 68 6f 73 74 2d tinfo (get-host-
f810: 6e 61 6d 65 29 29 29 29 29 29 0a 3b 3b 3b 20 20 name)))))).;;;
f820: 20 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 20 20 20 (cond.;;;
f830: 20 20 28 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 ((null? all-my
f840: 2d 61 64 64 72 65 73 73 65 73 29 0a 3b 3b 3b 20 -addresses).;;;
f850: 20 20 20 20 20 20 28 67 65 74 2d 68 6f 73 74 2d (get-host-
f860: 6e 61 6d 65 29 29 20 20 20 20 20 20 20 20 20 20 name))
f870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f890: 3b 3b 20 6e 6f 20 69 6e 74 65 72 66 61 63 65 73 ;; no interfaces
f8a0: 3f 0a 3b 3b 3b 20 20 20 20 20 20 28 28 65 71 3f ?.;;; ((eq?
f8b0: 20 28 6c 65 6e 67 74 68 20 61 6c 6c 2d 6d 79 2d (length all-my-
f8c0: 61 64 64 72 65 73 73 65 73 29 20 31 29 0a 3b 3b addresses) 1).;;
f8d0: 3b 20 20 20 20 20 20 20 28 69 70 2d 3e 73 74 72 ; (ip->str
f8e0: 69 6e 67 20 28 63 61 72 20 61 6c 6c 2d 6d 79 2d ing (car all-my-
f8f0: 61 64 64 72 65 73 73 65 73 29 29 29 20 20 20 20 addresses)))
f900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f910: 20 20 3b 3b 20 6f 6e 6c 79 20 6f 6e 65 20 74 6f ;; only one to
f920: 20 63 68 6f 6f 73 65 20 66 72 6f 6d 2c 20 6a 75 choose from, ju
f930: 73 74 20 67 6f 20 77 69 74 68 20 69 74 0a 3b 3b st go with it.;;
f940: 3b 20 20 20 20 20 20 28 65 6c 73 65 20 0a 3b 3b ; (else .;;
f950: 3b 20 20 20 20 20 20 20 28 69 70 2d 3e 73 74 72 ; (ip->str
f960: 69 6e 67 20 28 63 61 72 20 28 66 69 6c 74 65 72 ing (car (filter
f970: 20 28 6c 61 6d 62 64 61 20 28 78 29 20 20 20 20 (lambda (x)
f980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f990: 20 20 3b 3b 20 74 61 6b 65 20 61 6e 79 20 62 75 ;; take any bu
f9a0: 74 20 31 32 37 2e 0a 3b 3b 3b 20 09 09 09 09 20 t 127..;;; ....
f9b0: 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 (not (eq? (u8vec
f9c0: 74 6f 72 2d 72 65 66 20 78 20 30 29 20 31 32 37 tor-ref x 0) 127
f9d0: 29 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 ))).;;; ...
f9e0: 20 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 all-my-address
f9f0: 65 73 29 29 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b es))))))).;;; .;
fa00: 3b 3b 20 3b 3b 20 77 68 6f 61 6d 69 3f 20 49 20 ;; ;; whoami? I
fa10: 61 6d 20 6d 79 20 70 6b 74 0a 3b 3b 3b 20 3b 3b am my pkt.;;; ;;
fa20: 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 77 68 .;;; (define (wh
fa30: 6f 61 6d 69 3f 20 61 63 66 67 29 0a 3b 3b 3b 20 oami? acfg).;;;
fa40: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
fa50: 66 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d f/default (area-
fa60: 68 6f 73 74 73 20 61 63 66 67 29 28 61 72 65 61 hosts acfg)(area
fa70: 2d 70 6b 74 69 64 20 61 63 66 67 29 20 23 66 29 -pktid acfg) #f)
fa80: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d ).;;; .;;; ;;===
fa90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
faa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fad0: 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 22 43 6c 69 65 ===.;;; ;; "Clie
fae0: 6e 74 20 73 69 64 65 22 20 6f 70 65 72 61 74 69 nt side" operati
faf0: 6f 6e 73 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d ons.;;; ;;======
fb00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb40: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e .;;; .;;; (defin
fb50: 65 20 28 73 61 66 65 2d 63 61 6c 6c 20 63 61 6c e (safe-call cal
fb60: 6c 2d 6b 65 79 20 68 6f 73 74 20 70 6f 72 74 20 l-key host port
fb70: 2e 20 70 61 72 61 6d 73 29 0a 3b 3b 3b 20 20 20 . params).;;;
fb80: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
fb90: 6e 73 0a 3b 3b 3b 20 20 20 20 65 78 6e 0a 3b 3b ns.;;; exn.;;
fba0: 3b 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 ; (begin.;;;
fbb0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 43 61 6c (print "Cal
fbc0: 6c 20 22 20 63 61 6c 6c 2d 6b 65 79 20 22 20 74 l " call-key " t
fbd0: 6f 20 22 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 o " host ":" por
fbe0: 74 20 22 20 66 61 69 6c 65 64 22 29 0a 3b 3b 3b t " failed").;;;
fbf0: 20 20 20 20 20 20 23 66 29 0a 3b 3b 3b 20 20 20 #f).;;;
fc00: 20 28 61 70 70 6c 79 20 28 72 70 63 3a 70 72 6f (apply (rpc:pro
fc10: 63 65 64 75 72 65 20 63 61 6c 6c 2d 6b 65 79 20 cedure call-key
fc20: 68 6f 73 74 20 70 6f 72 74 29 20 70 61 72 61 6d host port) param
fc30: 73 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b s))).;;; .;;; ;;
fc40: 20 3b 3b 20 63 6f 6e 76 65 72 74 20 74 6f 2f 66 ;; convert to/f
fc50: 72 6f 6d 20 73 74 72 69 6e 67 20 2f 20 73 65 78 rom string / sex
fc60: 70 72 0a 3b 3b 3b 20 3b 3b 20 0a 3b 3b 3b 20 3b pr.;;; ;; .;;; ;
fc70: 3b 20 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e ; (define (strin
fc80: 67 2d 3e 73 65 78 70 72 20 73 74 72 29 0a 3b 3b g->sexpr str).;;
fc90: 3b 20 3b 3b 20 20 20 28 69 66 20 28 73 74 72 69 ; ;; (if (stri
fca0: 6e 67 3f 20 73 74 72 29 0a 3b 3b 3b 20 3b 3b 20 ng? str).;;; ;;
fcb0: 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 (with-inpu
fcc0: 74 2d 66 72 6f 6d 2d 73 74 72 69 6e 67 20 73 74 t-from-string st
fcd0: 72 20 72 65 61 64 29 0a 3b 3b 3b 20 3b 3b 20 20 r read).;;; ;;
fce0: 20 20 20 20 20 73 74 72 29 29 0a 3b 3b 3b 20 3b str)).;;; ;
fcf0: 3b 20 0a 3b 3b 3b 20 3b 3b 20 28 64 65 66 69 6e ; .;;; ;; (defin
fd00: 65 20 28 73 65 78 70 72 2d 3e 73 74 72 69 6e 67 e (sexpr->string
fd10: 20 73 29 0a 3b 3b 3b 20 3b 3b 20 20 20 28 77 69 s).;;; ;; (wi
fd20: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 th-output-to-str
fd30: 69 6e 67 20 28 6c 61 6d 62 64 61 20 28 29 28 77 ing (lambda ()(w
fd40: 72 69 74 65 20 73 29 29 29 29 0a 3b 3b 3b 20 0a rite s)))).;;; .
fd50: 3b 3b 3b 20 3b 3b 20 69 73 20 74 68 65 20 73 65 ;;; ;; is the se
fd60: 72 76 65 72 20 61 6c 69 76 65 3f 0a 3b 3b 3b 20 rver alive?.;;;
fd70: 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;.;;; (define (
fd80: 70 69 6e 67 20 61 63 66 67 20 68 6f 73 74 20 70 ping acfg host p
fd90: 6f 72 74 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a ort).;;; (let*
fda0: 20 28 28 6d 79 61 64 64 72 20 20 20 20 20 28 61 ((myaddr (a
fdb0: 72 65 61 2d 6d 79 61 64 64 72 20 61 63 66 67 29 rea-myaddr acfg)
fdc0: 29 0a 3b 3b 3b 20 09 20 28 6d 79 70 6f 72 74 20 ).;;; . (myport
fdd0: 20 20 20 20 28 61 72 65 61 2d 70 6f 72 74 20 20 (area-port
fde0: 20 61 63 66 67 29 29 0a 3b 3b 3b 20 09 20 28 73 acfg)).;;; . (s
fdf0: 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 tart-time (curre
fe00: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
fe10: 29 0a 3b 3b 3b 20 09 20 28 72 65 73 20 20 20 20 ).;;; . (res
fe20: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 (if (and (eq
fe30: 75 61 6c 3f 20 6d 79 61 64 64 72 20 68 6f 73 74 ual? myaddr host
fe40: 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 28 ).;;; ... (
fe50: 65 71 75 61 6c 3f 20 6d 79 70 6f 72 74 20 70 6f equal? myport po
fe60: 72 74 29 29 0a 3b 3b 3b 20 09 09 09 20 28 72 65 rt)).;;; ... (re
fe70: 61 6c 2d 70 69 6e 67 20 61 63 66 67 29 0a 3b 3b al-ping acfg).;;
fe80: 3b 20 09 09 09 20 28 28 72 70 63 3a 70 72 6f 63 ; ... ((rpc:proc
fe90: 65 64 75 72 65 20 27 70 69 6e 67 20 68 6f 73 74 edure 'ping host
fea0: 20 70 6f 72 74 29 29 29 29 29 0a 3b 3b 3b 20 20 port))))).;;;
feb0: 20 20 20 28 63 6f 6e 73 20 28 2d 20 28 63 75 72 (cons (- (cur
fec0: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
fed0: 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 3b s) start-time).;
fee0: 3b 3b 20 09 20 20 72 65 73 29 29 29 0a 3b 3b 3b ;; . res))).;;;
fef0: 20 0a 3b 3b 3b 20 3b 3b 20 72 65 74 75 72 6e 73 .;;; ;; returns
ff00: 20 28 20 69 70 61 64 64 72 20 70 6f 72 74 20 61 ( ipaddr port a
ff10: 6c 69 73 74 2d 66 6e 61 6d 65 3d 3e 72 61 6e 64 list-fname=>rand
ff20: 6e 75 6d 20 29 0a 3b 3b 3b 20 28 64 65 66 69 6e num ).;;; (defin
ff30: 65 20 28 72 65 61 6c 2d 70 69 6e 67 20 61 63 66 e (real-ping acf
ff40: 67 29 0a 3b 3b 3b 20 20 20 60 28 2c 28 61 72 65 g).;;; `(,(are
ff50: 61 2d 6d 79 61 64 64 72 20 61 63 66 67 29 20 2c a-myaddr acfg) ,
ff60: 28 61 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 (area-port acfg)
ff70: 20 2c 28 67 65 74 2d 68 6f 73 74 2d 73 74 61 74 ,(get-host-stat
ff80: 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 0a 3b s acfg))).;;; .;
ff90: 3b 3b 20 3b 3b 20 69 73 20 74 68 65 20 73 65 72 ;; ;; is the ser
ffa0: 76 65 72 20 61 6c 69 76 65 20 41 4e 44 20 74 68 ver alive AND th
ffb0: 65 20 71 75 65 75 65 73 20 70 72 6f 63 65 73 73 e queues process
ffc0: 69 6e 67 3f 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 ing?.;;; ;;.;;;
ffd0: 23 3b 28 64 65 66 69 6e 65 20 28 66 75 6c 6c 2d #;(define (full-
ffe0: 70 69 6e 67 20 61 63 66 67 20 73 65 72 76 70 6b ping acfg servpk
fff0: 74 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 t).;;; (let* (
10000 28 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 (start-time (cur
10010 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
10020 73 29 29 0a 3b 3b 3b 20 09 20 28 72 65 73 20 20 s)).;;; . (res
10030 20 20 20 20 20 20 28 73 65 6e 64 2d 6d 65 73 73 (send-mess
10040 61 67 65 20 61 63 66 67 20 73 65 72 76 70 6b 74 age acfg servpkt
10050 20 27 28 66 75 6c 6c 2d 70 69 6e 67 29 20 27 66 '(full-ping) 'f
10060 75 6c 6c 2d 70 69 6e 67 29 29 29 0a 3b 3b 3b 20 ull-ping))).;;;
10070 20 20 20 20 28 63 6f 6e 73 20 28 2d 20 28 63 75 (cons (- (cu
10080 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
10090 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 0a ds) start-time).
100a0 3b 3b 3b 20 09 20 20 72 65 73 29 29 29 20 3b 3b ;;; . res))) ;;
100b0 20 28 65 71 75 61 6c 3f 20 72 65 73 20 22 67 6f (equal? res "go
100c0 74 20 70 69 6e 67 22 29 29 29 29 0a 3b 3b 3b 20 t ping")))).;;;
100d0 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 6c 6f 6f .;;; .;;; ;; loo
100e0 6b 20 75 70 20 61 6c 6c 20 70 6b 74 73 20 61 6e k up all pkts an
100f0 64 20 67 65 74 20 74 68 65 20 73 65 72 76 65 72 d get the server
10100 20 69 64 20 28 74 68 65 20 68 61 73 68 29 2c 20 id (the hash),
10110 70 6f 72 74 2c 20 68 6f 73 74 2f 69 70 0a 3b 3b port, host/ip.;;
10120 3b 20 3b 3b 20 73 74 6f 72 65 20 74 68 69 73 20 ; ;; store this
10130 69 6e 66 6f 20 69 6e 20 61 63 66 67 0a 3b 3b 3b info in acfg.;;;
10140 20 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 20 6e ;; return the n
10150 75 6d 62 65 72 20 6f 66 20 72 65 73 70 6f 6e 73 umber of respons
10160 69 76 65 20 73 65 72 76 65 72 73 20 66 6f 75 6e ive servers foun
10170 64 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 d.;;; ;;.;;; ;;
10180 44 4f 20 4e 4f 54 20 56 45 52 49 46 59 20 54 48 DO NOT VERIFY TH
10190 41 54 20 54 48 45 20 53 45 52 56 45 52 20 49 53 AT THE SERVER IS
101a0 20 41 4c 49 56 45 20 48 45 52 45 2e 20 54 68 69 ALIVE HERE. Thi
101b0 73 20 69 73 20 63 61 6c 6c 65 64 20 61 74 20 74 s is called at t
101c0 69 6d 65 73 20 77 68 65 72 65 20 74 68 65 20 63 imes where the c
101d0 75 72 72 65 6e 74 20 73 65 72 76 65 72 20 69 73 urrent server is
101e0 20 6e 6f 74 20 79 65 74 20 61 6c 69 76 65 20 61 not yet alive a
101f0 6e 64 20 63 61 6e 6e 6f 74 20 70 69 6e 67 20 69 nd cannot ping i
10200 74 73 65 6c 66 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b tself.;;; ;;.;;;
10210 20 28 64 65 66 69 6e 65 20 28 75 70 64 61 74 65 (define (update
10220 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 20 61 -known-servers a
10230 63 66 67 29 0a 3b 3b 3b 20 20 20 3b 3b 20 72 65 cfg).;;; ;; re
10240 61 64 6c 6c 20 61 6c 6c 20 70 6b 74 73 0a 3b 3b adll all pkts.;;
10250 3b 20 20 20 3b 3b 20 66 6f 72 65 61 63 68 20 70 ; ;; foreach p
10260 6b 74 3b 20 69 66 20 69 74 20 69 73 6e 27 74 20 kt; if it isn't
10270 6d 65 20 70 69 6e 67 20 74 68 65 20 73 65 72 76 me ping the serv
10280 65 72 3b 20 69 66 20 61 6c 69 76 65 2c 20 61 64 er; if alive, ad
10290 64 20 74 6f 20 68 6f 73 74 73 20 68 61 73 68 2c d to hosts hash,
102a0 20 65 6c 73 65 20 72 6d 20 74 68 65 20 70 6b 74 else rm the pkt
102b0 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 73 .;;; (let* ((s
102c0 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 tart-time (curre
102d0 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
102e0 29 0a 3b 3b 3b 20 09 20 28 61 6c 6c 2d 70 6b 74 ).;;; . (all-pkt
102f0 73 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 s (delete-dupli
10300 63 61 74 65 73 0a 3b 3b 3b 20 09 09 20 20 20 20 cates.;;; ..
10310 20 28 61 70 70 65 6e 64 20 28 67 65 74 2d 61 6c (append (get-al
10320 6c 2d 73 65 72 76 65 72 2d 70 6b 74 73 20 61 63 l-server-pkts ac
10330 66 67 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 fg).;;; ...
10340 28 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 (hash-table-valu
10350 65 73 20 28 61 72 65 61 2d 68 6f 73 74 73 20 61 es (area-hosts a
10360 63 66 67 29 29 29 29 29 0a 3b 3b 3b 20 09 20 28 cfg))))).;;; . (
10370 68 6f 73 74 73 68 61 73 68 20 28 61 72 65 61 2d hostshash (area-
10380 68 6f 73 74 73 20 61 63 66 67 29 29 0a 3b 3b 3b hosts acfg)).;;;
10390 20 09 20 28 6d 79 2d 69 64 20 20 20 20 20 28 61 . (my-id (a
103a0 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 29 rea-pktid acfg))
103b0 0a 3b 3b 3b 20 09 20 28 70 6b 74 73 64 69 72 20 .;;; . (pktsdir
103c0 20 20 28 61 72 65 61 2d 70 6b 74 73 64 69 72 20 (area-pktsdir
103d0 61 63 66 67 29 29 20 3b 3b 20 6e 65 65 64 65 64 acfg)) ;; needed
103e0 20 74 6f 20 72 65 6d 6f 76 65 20 70 6b 74 73 20 to remove pkts
103f0 66 72 6f 6d 20 6e 6f 6e 2d 72 65 73 70 6f 6e 73 from non-respons
10400 69 76 65 20 73 65 72 76 65 72 73 0a 3b 3b 3b 20 ive servers.;;;
10410 09 20 28 6e 75 6d 73 72 76 73 20 20 20 30 29 0a . (numsrvs 0).
10420 3b 3b 3b 20 09 20 28 64 65 6c 70 6b 74 20 20 20 ;;; . (delpkt
10430 20 28 6c 61 6d 62 64 61 20 28 70 6b 74 73 64 69 (lambda (pktsdi
10440 72 20 73 69 64 29 0a 3b 3b 3b 20 09 09 20 20 20 r sid).;;; ..
10450 20 20 20 28 70 72 69 6e 74 20 22 63 6c 65 61 72 (print "clear
10460 69 6e 67 20 6f 75 74 20 73 65 72 76 65 72 20 22 ing out server "
10470 20 73 69 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 sid).;;; ..
10480 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 (delete-file*
10490 28 63 6f 6e 63 20 70 6b 74 73 64 69 72 20 22 2f (conc pktsdir "/
104a0 22 20 73 69 64 20 22 2e 70 6b 74 22 29 29 0a 3b " sid ".pkt")).;
104b0 3b 3b 20 09 09 20 20 20 20 20 20 28 68 61 73 68 ;; .. (hash
104c0 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 -table-delete! h
104d0 6f 73 74 73 68 61 73 68 20 73 69 64 29 29 29 29 ostshash sid))))
104e0 0a 3b 3b 3b 20 20 20 20 20 28 61 72 65 61 2d 6c .;;; (area-l
104f0 61 73 74 2d 73 72 76 75 70 2d 73 65 74 21 20 61 ast-srvup-set! a
10500 63 66 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 cfg (current-sec
10510 6f 6e 64 73 29 29 0a 3b 3b 3b 20 20 20 20 20 28 onds)).;;; (
10520 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 20 20 20 for-each.;;;
10530 20 20 28 6c 61 6d 62 64 61 20 28 73 65 72 76 70 (lambda (servp
10540 6b 74 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 kt).;;; (
10550 69 66 20 28 6c 69 73 74 3f 20 73 65 72 76 70 6b if (list? servpk
10560 74 29 0a 3b 3b 3b 20 09 20 20 20 3b 3b 20 28 70 t).;;; . ;; (p
10570 70 20 73 65 72 76 70 6b 74 29 0a 3b 3b 3b 20 09 p servpkt).;;; .
10580 20 20 20 28 6c 65 74 2a 20 28 28 73 68 6f 73 74 (let* ((shost
10590 20 28 61 6c 69 73 74 2d 72 65 66 20 27 69 70 61 (alist-ref 'ipa
105a0 64 64 72 20 73 65 72 76 70 6b 74 29 29 0a 3b 3b ddr servpkt)).;;
105b0 3b 20 09 09 20 20 28 73 70 6f 72 74 20 28 61 6e ; .. (sport (an
105c0 79 2d 3e 6e 75 6d 62 65 72 20 28 61 6c 69 73 74 y->number (alist
105d0 2d 72 65 66 20 27 70 6f 72 74 20 73 65 72 76 70 -ref 'port servp
105e0 6b 74 29 29 29 0a 3b 3b 3b 20 09 09 20 20 28 72 kt))).;;; .. (r
105f0 65 73 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 es (handle-exc
10600 65 70 74 69 6f 6e 73 0a 3b 3b 3b 20 09 09 09 20 eptions.;;; ...
10610 20 65 78 6e 0a 3b 3b 3b 20 09 09 09 20 20 28 62 exn.;;; ... (b
10620 65 67 69 6e 0a 3b 3b 3b 20 09 09 09 20 20 20 20 egin.;;; ...
10630 3b 3b 20 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a ;; (print "INFO:
10640 20 62 61 64 20 73 65 72 76 65 72 20 6f 6e 20 22 bad server on "
10650 20 73 68 6f 73 74 20 22 3a 22 20 73 70 6f 72 74 shost ":" sport
10660 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 23 66 29 ).;;; ... #f)
10670 0a 3b 3b 3b 20 09 09 09 20 20 28 70 69 6e 67 20 .;;; ... (ping
10680 61 63 66 67 20 73 68 6f 73 74 20 73 70 6f 72 74 acfg shost sport
10690 29 29 29 0a 3b 3b 3b 20 09 09 20 20 28 73 69 64 ))).;;; .. (sid
106a0 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 5a (alist-ref 'Z
106b0 20 73 65 72 76 70 6b 74 29 29 20 3b 3b 20 5a 20 servpkt)) ;; Z
106c0 63 6f 64 65 20 69 73 20 6f 75 72 20 6e 61 6d 65 code is our name
106d0 20 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 0a for the server.
106e0 3b 3b 3b 20 09 09 20 20 28 75 72 6c 20 20 20 28 ;;; .. (url (
106f0 63 6f 6e 63 20 73 68 6f 73 74 20 22 3a 22 20 73 conc shost ":" s
10700 70 6f 72 74 29 29 0a 3b 3b 3b 20 09 09 20 20 29 port)).;;; .. )
10710 0a 3b 3b 3b 20 09 20 20 20 20 20 23 3b 28 69 66 .;;; . #;(if
10720 20 28 6f 72 20 28 6e 6f 74 20 72 65 73 29 0a 3b (or (not res).;
10730 3b 3b 20 09 09 20 20 20 20 20 28 6e 75 6c 6c 3f ;; .. (null?
10740 20 72 65 73 29 29 0a 3b 3b 3b 20 09 09 20 28 62 res)).;;; .. (b
10750 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 28 70 egin.;;; .. (p
10760 72 69 6e 74 20 22 53 54 52 41 4e 47 45 3a 20 70 rint "STRANGE: p
10770 69 6e 67 20 6f 66 20 22 20 75 72 6c 20 22 20 67 ing of " url " g
10780 61 76 65 20 22 20 72 65 73 29 29 29 0a 3b 3b 3b ave " res))).;;;
10790 20 09 20 20 20 20 20 0a 3b 3b 3b 20 09 20 20 20 . .;;; .
107a0 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 47 6f 74 ;; (print "Got
107b0 20 22 20 72 65 73 20 22 20 66 72 6f 6d 20 22 20 " res " from "
107c0 73 68 6f 73 74 20 22 3a 22 20 73 70 6f 72 74 29 shost ":" sport)
107d0 0a 3b 3b 3b 20 09 20 20 20 20 20 28 6d 61 74 63 .;;; . (matc
107e0 68 20 72 65 73 0a 3b 3b 3b 20 09 09 20 20 20 20 h res.;;; ..
107f0 28 28 71 64 75 72 61 74 69 6f 6e 20 2e 20 70 61 ((qduration . pa
10800 79 6c 6f 61 64 29 0a 3b 3b 3b 20 09 09 20 20 20 yload).;;; ..
10810 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 53 65 72 ;; (print "Ser
10820 76 65 72 20 70 6b 74 3a 22 20 28 61 6c 69 73 74 ver pkt:" (alist
10830 2d 72 65 66 20 27 69 70 61 64 64 72 20 73 65 72 -ref 'ipaddr ser
10840 76 70 6b 74 29 20 22 3a 22 20 28 61 6c 69 73 74 vpkt) ":" (alist
10850 2d 72 65 66 20 27 70 6f 72 74 20 73 65 72 76 70 -ref 'port servp
10860 6b 74 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b kt).;;; .. ;
10870 3b 20 20 20 20 20 20 20 20 28 69 66 20 70 61 79 ; (if pay
10880 6c 6f 61 64 0a 3b 3b 3b 20 09 09 20 20 20 20 20 load.;;; ..
10890 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 22 53 ;; "S
108a0 75 63 63 65 73 73 22 20 22 46 61 69 6c 22 29 29 uccess" "Fail"))
108b0 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 6d 61 74 .;;; .. (mat
108c0 63 68 20 70 61 79 6c 6f 61 64 0a 3b 3b 3b 20 09 ch payload.;;; .
108d0 09 09 20 20 20 20 28 28 68 6f 73 74 20 70 6f 72 .. ((host por
108e0 74 20 73 74 61 74 73 29 0a 3b 3b 3b 20 09 09 09 t stats).;;; ...
108f0 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
10900 46 72 6f 6d 20 22 20 68 6f 73 74 20 22 3a 22 20 From " host ":"
10910 70 6f 72 74 20 22 20 67 6f 74 20 73 74 61 74 73 port " got stats
10920 3a 20 22 20 73 74 61 74 73 29 0a 3b 3b 3b 20 09 : " stats).;;; .
10930 09 09 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 .. (if (and
10940 68 6f 73 74 20 70 6f 72 74 20 73 74 61 74 73 29 host port stats)
10950 0a 3b 3b 3b 20 09 09 09 09 20 28 6c 65 74 20 28 .;;; .... (let (
10960 28 75 72 6c 20 28 63 6f 6e 63 20 68 6f 73 74 20 (url (conc host
10970 22 3a 22 20 70 6f 72 74 29 29 29 0a 3b 3b 3b 20 ":" port))).;;;
10980 09 09 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 .... (hash-tab
10990 6c 65 2d 73 65 74 21 20 68 6f 73 74 73 68 61 73 le-set! hostshas
109a0 68 20 73 69 64 20 73 65 72 76 70 6b 74 29 0a 3b h sid servpkt).;
109b0 3b 3b 20 09 09 09 09 20 20 20 3b 3b 20 73 74 6f ;; .... ;; sto
109c0 72 65 20 62 61 73 65 64 20 6f 6e 20 68 6f 73 74 re based on host
109d0 3a 70 6f 72 74 0a 3b 3b 3b 20 09 09 09 09 20 20 :port.;;; ....
109e0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
109f0 21 20 28 61 72 65 61 2d 68 6f 73 74 73 74 61 74 ! (area-hoststat
10a00 73 20 61 63 66 67 29 20 73 69 64 20 73 74 61 74 s acfg) sid stat
10a10 73 29 29 0a 3b 3b 3b 20 09 09 09 09 20 28 70 72 s)).;;; .... (pr
10a20 69 6e 74 20 22 6d 69 73 73 69 6e 67 20 64 61 74 int "missing dat
10a30 61 20 66 72 6f 6d 20 74 68 65 20 73 65 72 76 65 a from the serve
10a40 72 2c 20 6e 6f 74 20 73 75 72 65 20 77 68 61 74 r, not sure what
10a50 20 74 68 61 74 20 6d 65 61 6e 73 21 22 29 29 0a that means!")).
10a60 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 73 65 74 ;;; ... (set
10a70 21 20 6e 75 6d 73 72 76 73 20 28 2b 20 6e 75 6d ! numsrvs (+ num
10a80 73 72 76 73 20 31 29 29 29 0a 3b 3b 3b 20 09 09 srvs 1))).;;; ..
10a90 09 20 20 20 20 28 23 66 0a 3b 3b 3b 20 09 09 09 . (#f.;;; ...
10aa0 20 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 6d (print "Rem
10ab0 6f 76 69 6e 67 20 70 6b 74 20 22 20 73 69 64 20 oving pkt " sid
10ac0 22 20 64 75 65 20 74 6f 20 23 66 20 66 72 6f 6d " due to #f from
10ad0 20 73 65 72 76 65 72 20 6f 72 20 66 61 69 6c 65 server or faile
10ae0 64 20 70 69 6e 67 22 29 0a 3b 3b 3b 20 09 09 09 d ping").;;; ...
10af0 20 20 20 20 20 28 64 65 6c 70 6b 74 20 70 6b 74 (delpkt pkt
10b00 73 64 69 72 20 73 69 64 29 29 0a 3b 3b 3b 20 09 sdir sid)).;;; .
10b10 09 09 20 20 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 .. (else.;;;
10b20 09 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 ... (print "
10b30 47 6f 74 20 22 29 28 70 70 20 72 65 73 29 28 70 Got ")(pp res)(p
10b40 72 69 6e 74 20 22 20 66 72 6f 6d 20 73 65 72 76 rint " from serv
10b50 65 72 20 22 29 28 70 70 20 73 65 72 76 70 6b 74 er ")(pp servpkt
10b60 29 20 22 20 62 75 74 20 72 65 73 70 6f 6e 73 65 ) " but response
10b70 20 64 69 64 20 6e 6f 74 20 6d 61 74 63 68 20 28 did not match (
10b80 23 66 2f 23 74 20 2e 20 6d 73 67 29 22 29 29 29 #f/#t . msg)")))
10b90 0a 3b 3b 3b 20 09 09 20 20 20 20 28 65 6c 73 65 .;;; .. (else
10ba0 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 68 .;;; .. ;; h
10bb0 65 72 65 20 77 65 20 64 65 6c 65 74 65 20 74 68 ere we delete th
10bc0 65 20 70 6b 74 20 2d 20 63 61 6e 27 74 20 72 65 e pkt - can't re
10bd0 61 63 68 20 74 68 65 20 73 65 72 76 65 72 2c 20 ach the server,
10be0 72 65 6d 6f 76 65 20 69 74 0a 3b 3b 3b 20 09 09 remove it.;;; ..
10bf0 20 20 20 20 20 3b 3b 20 68 6f 77 65 76 65 72 20 ;; however
10c00 74 68 69 73 20 6c 6f 67 69 63 20 69 73 20 69 6e this logic is in
10c10 61 64 65 71 75 61 74 65 2e 20 77 65 20 73 68 6f adequate. we sho
10c20 75 6c 64 20 6d 61 72 6b 20 74 68 65 20 73 65 72 uld mark the ser
10c30 76 65 72 20 61 73 20 63 68 65 63 6b 65 64 0a 3b ver as checked.;
10c40 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 61 6e 64 ;; .. ;; and
10c50 20 6e 6f 74 20 67 6f 6f 64 2c 20 69 66 20 69 74 not good, if it
10c60 20 68 61 70 70 65 6e 73 20 61 20 73 65 63 6f 6e happens a secon
10c70 64 20 74 69 6d 65 20 2d 20 74 68 65 6e 20 72 65 d time - then re
10c80 6d 6f 76 65 20 74 68 65 20 70 6b 74 0a 3b 3b 3b move the pkt.;;;
10c90 20 09 09 20 20 20 20 20 3b 3b 20 6f 72 20 73 6f .. ;; or so
10ca0 6d 65 74 68 69 6e 67 20 73 69 6d 69 6c 61 72 2e mething similar.
10cb0 20 49 2e 65 2e 20 64 6f 6e 27 74 20 62 65 20 74 I.e. don't be t
10cc0 6f 6f 20 71 75 69 63 6b 20 74 6f 20 61 73 73 75 oo quick to assu
10cd0 6d 65 20 74 68 65 20 73 65 72 76 65 72 20 69 73 me the server is
10ce0 20 77 65 64 67 65 64 20 6f 72 20 64 65 61 64 0a wedged or dead.
10cf0 3b 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 63 6f ;;; .. ;; co
10d00 75 6c 64 20 62 65 20 69 74 20 69 73 20 73 69 6d uld be it is sim
10d10 70 6c 79 20 74 6f 6f 20 62 75 73 79 20 74 6f 20 ply too busy to
10d20 72 65 70 6c 79 0a 3b 3b 3b 20 09 09 20 20 20 20 reply.;;; ..
10d30 20 28 6c 65 74 20 28 28 62 61 64 2d 70 69 6e 67 (let ((bad-ping
10d40 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 s (hash-table-re
10d50 66 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d f/default (area-
10d60 68 65 61 6c 74 68 20 61 63 66 67 29 20 75 72 6c health acfg) url
10d70 20 30 29 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 0))).;;; ..
10d80 20 20 20 28 69 66 20 28 3e 20 62 61 64 2d 70 69 (if (> bad-pi
10d90 6e 67 73 20 31 29 20 3b 3b 20 74 77 6f 20 62 61 ngs 1) ;; two ba
10da0 64 20 70 69 6e 67 73 20 2d 20 72 65 6d 6f 76 65 d pings - remove
10db0 20 70 6b 74 0a 3b 3b 3b 20 09 09 09 20 20 20 28 pkt.;;; ... (
10dc0 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 09 20 20 20 begin.;;; ...
10dd0 20 20 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a 20 (print "INFO:
10de0 22 20 62 61 64 2d 70 69 6e 67 73 20 22 20 62 61 " bad-pings " ba
10df0 64 20 72 65 73 70 6f 6e 73 65 73 20 66 72 6f 6d d responses from
10e00 20 22 20 75 72 6c 20 22 2c 20 64 65 6c 65 74 69 " url ", deleti
10e10 6e 67 20 70 6b 74 20 22 20 73 69 64 29 0a 3b 3b ng pkt " sid).;;
10e20 3b 20 09 09 09 20 20 20 20 20 28 64 65 6c 70 6b ; ... (delpk
10e30 74 20 70 6b 74 73 64 69 72 20 73 69 64 29 29 0a t pktsdir sid)).
10e40 3b 3b 3b 20 09 09 09 20 20 20 28 62 65 67 69 6e ;;; ... (begin
10e50 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 70 72 .;;; ... (pr
10e60 69 6e 74 20 22 49 4e 46 4f 3a 20 22 20 62 61 64 int "INFO: " bad
10e70 2d 70 69 6e 67 73 20 22 20 62 61 64 20 72 65 73 -pings " bad res
10e80 70 6f 6e 73 65 73 20 66 72 6f 6d 20 22 20 73 68 ponses from " sh
10e90 6f 73 74 20 22 3a 22 20 73 70 6f 72 74 20 22 20 ost ":" sport "
10ea0 6e 6f 74 20 64 65 6c 65 74 69 6e 67 20 70 6b 74 not deleting pkt
10eb0 20 79 65 74 22 29 0a 3b 3b 3b 20 09 09 09 20 20 yet").;;; ...
10ec0 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
10ed0 65 74 21 20 28 61 72 65 61 2d 68 65 61 6c 74 68 et! (area-health
10ee0 20 61 63 66 67 29 0a 3b 3b 3b 20 09 09 09 09 09 acfg).;;; .....
10ef0 20 20 20 20 20 20 75 72 6c 0a 3b 3b 3b 20 09 09 url.;;; ..
10f00 09 09 09 20 20 20 20 20 20 28 2b 20 28 68 61 73 ... (+ (has
10f10 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
10f20 75 6c 74 20 28 61 72 65 61 2d 68 65 61 6c 74 68 ult (area-health
10f30 20 61 63 66 67 29 20 75 72 6c 20 30 29 20 31 29 acfg) url 0) 1)
10f40 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 29 29 ).;;; ... ))
10f50 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 29 29 .;;; .. ))
10f60 29 29 0a 3b 3b 3b 20 09 20 20 20 3b 3b 20 73 65 )).;;; . ;; se
10f70 72 76 70 6b 74 20 69 73 20 6e 6f 74 20 61 63 74 rvpkt is not act
10f80 75 61 6c 6c 79 20 61 20 70 6b 74 3f 0a 3b 3b 3b ually a pkt?.;;;
10f90 20 09 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 . (begin.;;;
10fa0 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 42 61 . (print "Ba
10fb0 64 20 70 6b 74 20 22 20 73 65 72 76 70 6b 74 29 d pkt " servpkt)
10fc0 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 61 6c 6c ))).;;; all
10fd0 2d 70 6b 74 73 29 0a 3b 3b 3b 20 20 20 20 20 28 -pkts).;;; (
10fe0 73 64 62 67 3e 20 22 75 70 64 61 74 65 2d 6b 6e sdbg> "update-kn
10ff0 6f 77 6e 2d 73 65 72 76 65 72 73 22 20 22 65 6e own-servers" "en
11000 64 22 20 73 74 61 72 74 2d 74 69 6d 65 20 23 66 d" start-time #f
11010 20 23 66 20 22 20 66 6f 75 6e 64 20 22 20 6e 75 #f " found " nu
11020 6d 73 72 76 73 0a 3b 3b 3b 20 09 20 20 20 22 20 msrvs.;;; . "
11030 73 65 72 76 65 72 73 2c 20 70 6b 74 73 3a 20 22 servers, pkts: "
11040 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 (map (lambda (p
11050 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 20 28 ).;;; .... (
11060 61 6c 69 73 74 2d 72 65 66 20 27 5a 20 70 29 29 alist-ref 'Z p))
11070 0a 3b 3b 3b 20 09 09 09 09 20 20 20 61 6c 6c 2d .;;; .... all-
11080 70 6b 74 73 29 29 0a 3b 3b 3b 20 20 20 20 20 6e pkts)).;;; n
11090 75 6d 73 72 76 73 29 29 0a 3b 3b 3b 20 0a 3b 3b umsrvs)).;;; .;;
110a0 3b 20 28 64 65 66 73 74 72 75 63 74 20 73 72 76 ; (defstruct srv
110b0 73 74 61 74 0a 3b 3b 3b 20 20 20 28 6e 75 6d 66 stat.;;; (numf
110c0 69 6c 65 73 20 30 29 20 20 20 3b 3b 20 6e 75 6d iles 0) ;; num
110d0 62 65 72 20 6f 66 20 64 62 20 66 69 6c 65 73 20 ber of db files
110e0 68 61 6e 64 6c 65 64 20 62 79 20 74 68 69 73 20 handled by this
110f0 73 65 72 76 65 72 20 2d 20 73 75 62 74 72 61 63 server - subtrac
11100 74 20 31 20 66 6f 72 20 74 68 65 20 64 62 20 62 t 1 for the db b
11110 65 69 6e 67 20 63 75 72 72 65 6e 74 6c 79 20 6c eing currently l
11120 6f 6f 6b 65 64 20 61 74 0a 3b 3b 3b 20 20 20 28 ooked at.;;; (
11130 72 61 6e 64 6e 75 6d 20 20 23 66 29 20 20 3b 3b randnum #f) ;;
11140 20 74 69 65 20 62 72 65 61 6b 65 72 20 6e 75 6d tie breaker num
11150 62 65 72 20 61 73 73 69 67 6e 65 64 20 74 6f 20 ber assigned to
11160 62 79 20 74 68 65 20 73 65 72 76 65 72 20 69 74 by the server it
11170 73 65 6c 66 20 2d 20 61 70 70 6c 69 65 73 20 6f self - applies o
11180 6e 6c 79 20 74 6f 20 74 68 65 20 64 62 20 75 6e nly to the db un
11190 64 65 72 20 63 6f 6e 73 69 64 65 72 61 74 69 6f der consideratio
111a0 6e 0a 3b 3b 3b 20 20 20 28 70 6b 74 20 20 20 20 n.;;; (pkt
111b0 20 20 23 66 29 29 20 3b 3b 20 74 68 65 20 73 65 #f)) ;; the se
111c0 72 76 65 72 20 70 6b 74 0a 3b 3b 3b 20 0a 3b 3b rver pkt.;;; .;;
111d0 3b 20 3b 3b 28 64 65 66 69 6e 65 20 28 73 72 76 ; ;;(define (srv
111e0 2d 3e 73 72 76 73 74 61 74 20 73 72 76 70 6b 74 ->srvstat srvpkt
111f0 29 0a 3b 3b 3b 20 20 20 0a 3b 3b 3b 20 3b 3b 20 ).;;; .;;; ;;
11200 47 65 74 20 74 68 65 20 73 65 72 76 65 72 20 62 Get the server b
11210 65 73 74 20 66 6f 72 20 67 69 76 65 6e 20 64 62 est for given db
11220 6e 61 6d 65 20 61 6e 64 20 6b 65 79 0a 3b 3b 3b name and key.;;;
11230 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 20 20 4e 4f 54 ;;.;;; ;; NOT
11240 45 3a 20 6b 65 79 20 69 73 20 6e 6f 74 20 63 75 E: key is not cu
11250 72 72 65 6e 74 6c 79 20 75 73 65 64 2e 20 54 68 rrently used. Th
11260 65 20 6b 65 79 20 70 6f 69 6e 74 73 20 74 6f 20 e key points to
11270 74 68 65 20 6b 69 6e 64 20 6f 66 20 71 75 65 72 the kind of quer
11280 79 2c 20 74 68 69 73 20 6d 61 79 20 62 65 20 75 y, this may be u
11290 73 65 66 75 6c 20 66 6f 72 20 64 69 72 65 63 74 seful for direct
112a0 69 6e 67 20 72 65 61 64 2d 6f 6e 6c 79 20 71 75 ing read-only qu
112b0 65 72 69 65 73 2e 0a 3b 3b 3b 20 3b 3b 0a 3b 3b eries..;;; ;;.;;
112c0 3b 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d 62 ; (define (get-b
112d0 65 73 74 2d 73 65 72 76 65 72 20 61 63 66 67 20 est-server acfg
112e0 64 62 6e 61 6d 65 20 6b 65 79 29 0a 3b 3b 3b 20 dbname key).;;;
112f0 20 20 28 6c 65 74 2a 20 28 3b 3b 20 28 73 65 72 (let* (;; (ser
11300 76 65 72 73 20 28 68 61 73 68 2d 74 61 62 6c 65 vers (hash-table
11310 2d 76 61 6c 75 65 73 20 28 61 72 65 61 2d 68 6f -values (area-ho
11320 73 74 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 sts acfg))).;;;
11330 09 20 28 73 65 72 76 65 72 73 20 20 20 20 20 28 . (servers (
11340 61 72 65 61 2d 68 6f 73 74 73 20 61 63 66 67 29 area-hosts acfg)
11350 29 0a 3b 3b 3b 20 09 20 28 73 6b 65 79 73 20 20 ).;;; . (skeys
11360 20 20 20 20 20 28 73 6f 72 74 20 28 68 61 73 68 (sort (hash
11370 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 65 72 76 -table-keys serv
11380 65 72 73 29 20 73 74 72 69 6e 67 3e 3d 3f 29 29 ers) string>=?))
11390 20 3b 3b 20 61 20 73 74 61 62 6c 65 20 6c 69 73 ;; a stable lis
113a0 74 69 6e 67 0a 3b 3b 3b 20 09 20 28 73 74 61 72 ting.;;; . (star
113b0 74 2d 74 69 6d 65 20 20 28 63 75 72 72 65 6e 74 t-time (current
113c0 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a -milliseconds)).
113d0 3b 3b 3b 20 09 20 28 73 72 76 73 74 61 74 73 20 ;;; . (srvstats
113e0 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
113f0 62 6c 65 29 29 20 20 3b 3b 20 73 72 76 69 64 20 ble)) ;; srvid
11400 3d 3e 20 73 72 76 73 74 61 74 0a 3b 3b 3b 20 09 => srvstat.;;; .
11410 20 28 75 72 6c 20 20 20 20 20 20 20 20 20 28 63 (url (c
11420 6f 6e 63 20 28 61 72 65 61 2d 6d 79 61 64 64 72 onc (area-myaddr
11430 20 61 63 66 67 29 20 22 3a 22 20 28 61 72 65 61 acfg) ":" (area
11440 2d 70 6f 72 74 20 61 63 66 67 29 29 29 29 0a 3b -port acfg)))).;
11450 3b 3b 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ;; ;; (print
11460 20 22 73 63 6f 72 65 73 20 66 6f 72 20 22 20 64 "scores for " d
11470 62 6e 61 6d 65 20 22 3a 20 22 20 28 6d 61 70 20 bname ": " (map
11480 28 6c 61 6d 62 64 61 20 28 6b 29 28 63 6f 6e 73 (lambda (k)(cons
11490 20 6b 20 28 63 61 6c 63 2d 73 65 72 76 65 72 2d k (calc-server-
114a0 73 63 6f 72 65 20 61 63 66 67 20 64 62 6e 61 6d score acfg dbnam
114b0 65 20 6b 29 29 29 20 73 6b 65 79 73 29 29 0a 3b e k))) skeys)).;
114c0 3b 3b 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ;; (if (null
114d0 3f 20 73 6b 65 79 73 29 0a 3b 3b 3b 20 09 28 69 ? skeys).;;; .(i
114e0 66 20 28 3e 20 28 75 70 64 61 74 65 2d 6b 6e 6f f (> (update-kno
114f0 77 6e 2d 73 65 72 76 65 72 73 20 61 63 66 67 29 wn-servers acfg)
11500 20 30 29 0a 3b 3b 3b 20 09 20 20 20 20 28 67 65 0).;;; . (ge
11510 74 2d 62 65 73 74 2d 73 65 72 76 65 72 20 61 63 t-best-server ac
11520 66 67 20 64 62 6e 61 6d 65 20 6b 65 79 29 20 3b fg dbname key) ;
11530 3b 20 73 6f 6d 65 20 72 69 73 6b 20 6f 66 20 69 ; some risk of i
11540 6e 66 69 6e 69 74 65 20 6c 6f 6f 70 20 68 65 72 nfinite loop her
11550 65 2c 20 54 4f 44 4f 20 61 64 64 20 74 72 79 20 e, TODO add try
11560 63 6f 75 6e 74 65 72 0a 3b 3b 3b 20 09 20 20 20 counter.;;; .
11570 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 20 (begin.;;; .
11580 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 (print "ERROR
11590 3a 20 6e 6f 20 73 65 72 76 65 72 20 66 6f 75 6e : no server foun
115a0 64 21 22 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 d!") ;; since th
115b0 69 73 20 70 72 6f 63 65 73 73 20 69 73 20 61 6c is process is al
115c0 73 6f 20 61 20 73 65 72 76 65 72 20 74 68 69 73 so a server this
115d0 20 73 68 6f 75 6c 64 20 6e 65 76 65 72 20 68 61 should never ha
115e0 70 70 65 6e 0a 3b 3b 3b 20 09 20 20 20 20 20 20 ppen.;;; .
115f0 23 66 29 29 0a 3b 3b 3b 20 09 28 62 65 67 69 6e #f)).;;; .(begin
11600 0a 3b 3b 3b 20 09 20 20 3b 3b 20 28 70 72 69 6e .;;; . ;; (prin
11610 74 20 22 69 6e 20 67 65 74 2d 62 65 73 74 2d 73 t "in get-best-s
11620 65 72 76 65 72 20 77 69 74 68 20 73 6b 65 79 73 erver with skeys
11630 3d 22 20 73 6b 65 79 73 29 0a 3b 3b 3b 20 09 20 =" skeys).;;; .
11640 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 (if (> (- (curr
11650 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 61 72 ent-seconds) (ar
11660 65 61 2d 6c 61 73 74 2d 73 72 76 75 70 20 61 63 ea-last-srvup ac
11670 66 67 29 29 20 31 30 29 0a 3b 3b 3b 20 09 20 20 fg)) 10).;;; .
11680 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 (begin.;;; .
11690 09 28 75 70 64 61 74 65 2d 6b 6e 6f 77 6e 2d 73 .(update-known-s
116a0 65 72 76 65 72 73 20 61 63 66 67 29 0a 3b 3b 3b ervers acfg).;;;
116b0 20 09 09 28 73 64 62 67 3e 20 22 67 65 74 2d 62 ..(sdbg> "get-b
116c0 65 73 74 2d 73 65 72 76 65 72 22 20 22 75 70 64 est-server" "upd
116d0 61 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 ate-known-server
116e0 73 22 20 73 74 61 72 74 2d 74 69 6d 65 20 23 66 s" start-time #f
116f0 20 23 66 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 #f))).;;; .;;;
11700 09 20 20 3b 3b 20 66 6f 72 20 65 61 63 68 20 73 . ;; for each s
11710 65 72 76 65 72 20 6c 6f 6f 6b 20 61 74 20 74 68 erver look at th
11720 65 20 6c 69 73 74 20 6f 66 20 64 62 66 69 6c 65 e list of dbfile
11730 73 2c 20 74 6f 74 61 6c 20 6e 75 6d 62 65 72 20 s, total number
11740 6f 66 20 64 62 73 20 62 65 69 6e 67 20 68 61 6e of dbs being han
11750 64 6c 65 64 0a 3b 3b 3b 20 09 20 20 3b 3b 20 61 dled.;;; . ;; a
11760 6e 64 20 74 68 65 20 72 61 6e 64 20 6e 75 6d 62 nd the rand numb
11770 65 72 2c 20 73 61 76 65 20 74 68 65 20 62 65 73 er, save the bes
11780 74 20 68 6f 73 74 0a 3b 3b 3b 20 09 20 20 3b 3b t host.;;; . ;;
11790 20 61 6c 73 6f 20 64 6f 20 61 20 64 65 6c 69 73 also do a delis
117a0 74 2d 64 62 20 66 6f 72 20 65 61 63 68 20 73 65 t-db for each se
117b0 72 76 65 72 20 64 62 66 69 6c 65 20 6e 6f 74 20 rver dbfile not
117c0 75 73 65 64 0a 3b 3b 3b 20 09 20 20 28 6c 65 74 used.;;; . (let
117d0 2a 20 28 28 62 65 73 74 2d 73 65 72 76 65 72 20 * ((best-server
117e0 20 20 20 20 20 20 23 66 29 0a 3b 3b 3b 20 09 09 #f).;;; ..
117f0 20 28 73 65 72 76 65 72 73 2d 74 6f 2d 64 65 6c (servers-to-del
11800 69 73 74 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ist (make-hash-t
11810 61 62 6c 65 29 29 29 0a 3b 3b 3b 20 09 20 20 20 able))).;;; .
11820 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 09 (for-each.;;; .
11830 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 72 (lambda (sr
11840 76 69 64 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 vid).;;; .
11850 20 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 20 (let* ((server
11860 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
11870 65 66 2f 64 65 66 61 75 6c 74 20 73 65 72 76 65 ef/default serve
11880 72 73 20 73 72 76 69 64 20 23 66 29 29 0a 3b 3b rs srvid #f)).;;
11890 3b 20 09 09 20 20 20 20 20 20 28 73 74 61 74 73 ; .. (stats
118a0 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
118b0 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 61 72 -ref/default (ar
118c0 65 61 2d 68 6f 73 74 73 74 61 74 73 20 61 63 66 ea-hoststats acf
118d0 67 29 20 73 72 76 69 64 20 27 28 28 29 29 29 29 g) srvid '(())))
118e0 29 0a 3b 3b 3b 20 09 09 20 3b 3b 20 28 70 72 69 ).;;; .. ;; (pri
118f0 6e 74 20 22 73 74 61 74 73 3a 20 22 20 73 74 61 nt "stats: " sta
11900 74 73 29 0a 3b 3b 3b 20 20 09 09 20 28 69 66 20 ts).;;; .. (if
11910 73 65 72 76 65 72 0a 3b 3b 3b 20 09 09 20 20 20 server.;;; ..
11920 20 20 28 6c 65 74 2a 20 28 28 64 62 77 65 69 67 (let* ((dbweig
11930 68 74 73 20 28 63 61 72 20 73 74 61 74 73 29 29 hts (car stats))
11940 0a 3b 3b 3b 20 09 09 09 20 20 20 20 28 73 72 76 .;;; ... (srv
11950 6c 6f 61 64 20 20 20 28 6c 65 6e 67 74 68 20 28 load (length (
11960 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
11970 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 64 x)(not (equal? d
11980 62 6e 61 6d 65 20 28 63 61 72 20 78 29 29 29 29 bname (car x))))
11990 20 64 62 77 65 69 67 68 74 73 29 29 29 0a 3b 3b dbweights))).;;
119a0 3b 20 09 09 09 20 20 20 20 28 64 62 72 65 63 20 ; ... (dbrec
119b0 20 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 64 (alist-ref d
119c0 62 6e 61 6d 65 20 64 62 77 65 69 67 68 74 73 20 bname dbweights
119d0 65 71 75 61 6c 3f 29 29 20 20 3b 3b 20 67 65 74 equal?)) ;; get
119e0 20 74 68 65 20 70 61 69 72 20 77 69 74 68 20 66 the pair with f
119f0 6e 61 6d 65 20 2e 20 72 61 6e 64 73 63 6f 72 65 name . randscore
11a00 0a 3b 3b 3b 20 09 09 09 20 20 20 20 28 72 61 6e .;;; ... (ran
11a10 64 6e 75 6d 20 20 20 28 69 66 20 64 62 72 65 63 dnum (if dbrec
11a20 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 64 62 72 .;;; ..... dbr
11a30 65 63 20 3b 3b 20 28 63 64 72 20 64 62 72 65 63 ec ;; (cdr dbrec
11a40 29 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 30 29 ).;;; ..... 0)
11a50 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 )).;;; ..
11a60 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
11a70 20 73 72 76 73 74 61 74 73 20 73 72 76 69 64 20 srvstats srvid
11a80 28 6d 61 6b 65 2d 73 72 76 73 74 61 74 20 6e 75 (make-srvstat nu
11a90 6d 66 69 6c 65 73 3a 20 73 72 76 6c 6f 61 64 20 mfiles: srvload
11aa0 72 61 6e 64 6e 75 6d 3a 20 72 61 6e 64 6e 75 6d randnum: randnum
11ab0 20 70 6b 74 3a 20 73 65 72 76 65 72 29 29 29 29 pkt: server))))
11ac0 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 73 6b 65 )).;;; . ske
11ad0 79 73 29 0a 3b 3b 3b 20 09 20 20 20 20 0a 3b 3b ys).;;; . .;;
11ae0 3b 20 09 20 20 20 20 28 6c 65 74 2a 20 28 28 73 ; . (let* ((s
11af0 6f 72 74 65 64 20 20 20 20 28 73 6f 72 74 20 28 orted (sort (
11b00 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 hash-table-value
11b10 73 20 73 72 76 73 74 61 74 73 29 20 0a 3b 3b 3b s srvstats) .;;;
11b20 20 09 09 09 09 20 20 20 20 28 6c 61 6d 62 64 61 .... (lambda
11b30 20 28 61 20 62 29 0a 3b 3b 3b 20 09 09 09 09 20 (a b).;;; ....
11b40 20 20 20 20 20 28 6c 65 74 20 28 28 6e 75 6d 66 (let ((numf
11b50 69 6c 65 73 2d 61 20 28 73 72 76 73 74 61 74 2d iles-a (srvstat-
11b60 6e 75 6d 66 69 6c 65 73 20 61 29 29 0a 3b 3b 3b numfiles a)).;;;
11b70 20 09 09 09 09 09 20 20 20 20 28 6e 75 6d 66 69 ..... (numfi
11b80 6c 65 73 2d 62 20 28 73 72 76 73 74 61 74 2d 6e les-b (srvstat-n
11b90 75 6d 66 69 6c 65 73 20 62 29 29 0a 3b 3b 3b 20 umfiles b)).;;;
11ba0 09 09 09 09 09 20 20 20 20 28 72 61 6e 64 6e 75 ..... (randnu
11bb0 6d 2d 61 20 20 28 73 72 76 73 74 61 74 2d 72 61 m-a (srvstat-ra
11bc0 6e 64 6e 75 6d 20 61 29 29 0a 3b 3b 3b 20 09 09 ndnum a)).;;; ..
11bd0 09 09 09 20 20 20 20 28 72 61 6e 64 6e 75 6d 2d ... (randnum-
11be0 62 20 20 28 73 72 76 73 74 61 74 2d 72 61 6e 64 b (srvstat-rand
11bf0 6e 75 6d 20 62 29 29 29 0a 3b 3b 3b 20 09 09 09 num b))).;;; ...
11c00 09 09 28 69 66 20 28 3c 20 6e 75 6d 66 69 6c 65 ..(if (< numfile
11c10 73 2d 61 20 6e 75 6d 66 69 6c 65 73 2d 62 29 20 s-a numfiles-b)
11c20 3b 3b 20 4e 6f 74 65 2c 20 49 20 64 6f 6e 27 74 ;; Note, I don't
11c30 20 74 68 69 6e 6b 20 61 64 64 69 6e 67 20 61 6e think adding an
11c40 20 6f 66 66 73 65 74 20 77 6f 72 6b 73 20 68 65 offset works he
11c50 72 65 2e 20 47 6f 61 6c 20 77 61 73 20 6f 6e 6c re. Goal was onl
11c60 79 20 6d 6f 76 65 20 66 69 6c 65 20 68 61 6e 64 y move file hand
11c70 6c 69 6e 67 20 74 6f 20 61 20 64 69 66 66 65 72 ling to a differ
11c80 65 6e 74 20 73 65 72 76 65 72 20 69 66 20 69 74 ent server if it
11c90 20 68 61 73 20 32 20 6c 65 73 73 0a 3b 3b 3b 20 has 2 less.;;;
11ca0 09 09 09 09 09 20 20 20 20 23 74 0a 3b 3b 3b 20 ..... #t.;;;
11cb0 09 09 09 09 09 20 20 20 20 28 69 66 20 28 61 6e ..... (if (an
11cc0 64 20 28 65 71 75 61 6c 3f 20 6e 75 6d 66 69 6c d (equal? numfil
11cd0 65 73 2d 61 20 6e 75 6d 66 69 6c 65 73 2d 62 29 es-a numfiles-b)
11ce0 0a 3b 3b 3b 20 09 09 09 09 09 09 20 20 20 20 20 .;;; ......
11cf0 28 3c 20 72 61 6e 64 6e 75 6d 2d 61 20 72 61 6e (< randnum-a ran
11d00 64 6e 75 6d 2d 62 29 29 0a 3b 3b 3b 20 09 09 09 dnum-b)).;;; ...
11d10 09 09 09 23 74 0a 3b 3b 3b 20 09 09 09 09 09 09 ...#t.;;; ......
11d20 23 66 29 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 #f)))))).;;; ..
11d30 20 20 28 62 65 73 74 20 20 20 20 20 20 28 69 66 (best (if
11d40 20 28 6e 75 6c 6c 3f 20 73 6f 72 74 65 64 29 0a (null? sorted).
11d50 3b 3b 3b 20 09 09 09 09 20 20 28 62 65 67 69 6e ;;; .... (begin
11d60 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 28 70 72 .;;; .... (pr
11d70 69 6e 74 20 22 45 52 52 4f 52 3a 20 73 68 6f 75 int "ERROR: shou
11d80 6c 64 20 6e 65 76 65 72 20 62 65 20 6e 75 6c 6c ld never be null
11d90 20 64 75 65 20 74 6f 20 73 65 6c 66 20 61 73 20 due to self as
11da0 73 65 72 76 65 72 2e 22 29 0a 3b 3b 3b 20 09 09 server.").;;; ..
11db0 09 09 20 20 20 20 23 66 29 0a 3b 3b 3b 20 09 09 .. #f).;;; ..
11dc0 09 09 20 20 28 73 72 76 73 74 61 74 2d 70 6b 74 .. (srvstat-pkt
11dd0 20 28 63 61 72 20 73 6f 72 74 65 64 29 29 29 29 (car sorted))))
11de0 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 23 3b 28 ).;;; . #;(
11df0 70 72 69 6e 74 20 22 53 45 52 56 45 52 28 22 20 print "SERVER("
11e00 75 72 6c 20 22 29 3a 20 22 20 64 62 6e 61 6d 65 url "): " dbname
11e10 20 22 3a 20 22 20 28 6d 61 70 20 28 6c 61 6d 62 ": " (map (lamb
11e20 64 61 20 28 73 72 76 29 0a 3b 3b 3b 20 09 09 09 da (srv).;;; ...
11e30 09 09 09 09 20 20 20 20 28 6c 65 74 20 28 28 70 .... (let ((p
11e40 20 28 73 72 76 73 74 61 74 2d 70 6b 74 20 73 72 (srvstat-pkt sr
11e50 76 29 29 29 0a 3b 3b 3b 20 09 09 09 09 09 09 09 v))).;;; .......
11e60 20 20 20 20 20 20 28 63 6f 6e 63 20 28 61 6c 69 (conc (ali
11e70 73 74 2d 72 65 66 20 27 69 70 61 64 64 72 20 70 st-ref 'ipaddr p
11e80 29 20 22 3a 22 20 28 61 6c 69 73 74 2d 72 65 66 ) ":" (alist-ref
11e90 20 27 70 6f 72 74 20 70 29 0a 3b 3b 3b 20 09 09 'port p).;;; ..
11ea0 09 09 09 09 09 09 20 20 20 20 22 28 22 20 28 73 ...... "(" (s
11eb0 72 76 73 74 61 74 2d 6e 75 6d 66 69 6c 65 73 20 rvstat-numfiles
11ec0 73 72 76 29 22 2c 22 28 73 72 76 73 74 61 74 2d srv)","(srvstat-
11ed0 72 61 6e 64 6e 75 6d 20 73 72 76 29 22 29 22 29 randnum srv)")")
11ee0 29 29 0a 3b 3b 3b 20 09 09 09 09 09 09 09 20 20 )).;;; .......
11ef0 20 20 73 6f 72 74 65 64 29 29 0a 3b 3b 3b 20 09 sorted)).;;; .
11f00 20 20 20 20 20 20 62 65 73 74 29 29 29 29 29 29 best))))))
11f10 0a 3b 3b 3b 20 20 20 20 20 0a 3b 3b 3b 20 20 20 .;;; .;;;
11f20 20 20 3b 3b 20 73 65 6e 64 20 6f 75 74 20 61 6e ;; send out an
11f30 20 22 49 27 6d 20 61 62 6f 75 74 20 74 6f 20 65 "I'm about to e
11f40 78 69 74 20 6e 6f 74 69 63 65 20 74 6f 20 61 6c xit notice to al
11f50 6c 20 6b 6e 6f 77 6e 20 73 65 72 76 65 72 73 22 l known servers"
11f60 0a 3b 3b 3b 20 20 20 20 20 3b 3b 0a 3b 3b 3b 20 .;;; ;;.;;;
11f70 28 64 65 66 69 6e 65 20 28 64 65 61 74 68 2d 69 (define (death-i
11f80 6d 6d 69 6e 65 6e 74 20 61 63 66 67 29 0a 3b 3b mminent acfg).;;
11f90 3b 20 20 20 27 28 29 29 0a 3b 3b 3b 20 0a 3b 3b ; '()).;;; .;;
11fa0 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ; ;;============
11fb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11fc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11fd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11fe0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b ==========.;;; ;
11ff0 3b 20 55 20 4c 20 45 20 58 20 20 2d 20 20 54 20 ; U L E X - T
12000 48 20 45 20 20 20 49 20 4e 20 54 20 45 20 52 20 H E I N T E R
12010 45 20 53 20 54 20 49 20 4e 20 47 20 20 20 53 20 E S T I N G S
12020 54 20 55 20 46 20 46 20 21 20 21 0a 3b 3b 3b 20 T U F F ! !.;;;
12030 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
12040 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12050 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12060 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12070 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b ========.;;; .;;
12080 3b 20 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 ; ;; register a
12090 68 61 6e 64 6c 65 72 0a 3b 3b 3b 20 3b 3b 20 20 handler.;;; ;;
120a0 20 4e 4f 54 45 53 3a 0a 3b 3b 3b 20 3b 3b 20 20 NOTES:.;;; ;;
120b0 20 20 20 64 62 69 6e 69 74 73 71 6c 20 20 20 69 dbinitsql i
120c0 73 20 72 65 73 65 72 76 65 64 20 66 6f 72 20 61 s reserved for a
120d0 20 6c 69 73 74 20 6f 66 20 73 71 6c 20 73 74 61 list of sql sta
120e0 74 65 6d 65 6e 74 73 20 66 6f 72 20 69 6e 69 74 tements for init
120f0 69 61 6c 69 7a 69 6e 67 20 74 68 65 20 64 62 0a ializing the db.
12100 3b 3b 3b 20 3b 3b 20 20 20 20 20 64 62 69 6e 69 ;;; ;; dbini
12110 74 66 6e 20 20 20 20 69 73 20 72 65 73 65 72 76 tfn is reserv
12120 65 64 20 66 6f 72 20 61 20 64 62 20 69 6e 69 74 ed for a db init
12130 20 66 75 6e 63 74 69 6f 6e 2c 20 69 66 20 65 78 function, if ex
12140 69 73 74 73 20 63 61 6c 6c 65 64 20 61 66 74 65 ists called afte
12150 72 20 64 62 69 6e 69 74 73 71 6c 0a 3b 3b 3b 20 r dbinitsql.;;;
12160 3b 3b 20 20 20 20 20 0a 3b 3b 3b 20 28 64 65 66 ;; .;;; (def
12170 69 6e 65 20 28 72 65 67 69 73 74 65 72 20 61 63 ine (register ac
12180 66 67 20 6b 65 79 20 6f 62 6a 20 23 21 6f 70 74 fg key obj #!opt
12190 69 6f 6e 61 6c 20 28 63 74 79 70 65 20 27 64 62 ional (ctype 'db
121a0 77 72 69 74 65 29 29 0a 3b 3b 3b 20 20 20 28 6c write)).;;; (l
121b0 65 74 20 28 28 68 74 20 28 61 72 65 61 2d 72 74 et ((ht (area-rt
121c0 61 62 6c 65 20 61 63 66 67 29 29 29 0a 3b 3b 3b able acfg))).;;;
121d0 20 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 (if (hash-t
121e0 61 62 6c 65 2d 65 78 69 73 74 73 3f 20 68 74 20 able-exists? ht
121f0 6b 65 79 29 0a 3b 3b 3b 20 09 28 70 72 69 6e 74 key).;;; .(print
12200 20 22 57 41 52 4e 49 4e 47 3a 20 72 65 64 65 66 "WARNING: redef
12210 69 6e 69 74 69 6f 6e 20 6f 66 20 65 6e 74 72 79 inition of entry
12220 20 22 20 6b 65 79 29 29 0a 3b 3b 3b 20 20 20 20 " key)).;;;
12230 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
12240 21 20 68 74 20 6b 65 79 20 28 6d 61 6b 65 2d 63 ! ht key (make-c
12250 61 6c 6c 64 61 74 20 6f 62 6a 3a 20 6f 62 6a 20 alldat obj: obj
12260 63 74 79 70 65 3a 20 63 74 79 70 65 29 29 29 29 ctype: ctype))))
12270 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 75 73 61 .;;; .;;; ;; usa
12280 67 65 3a 20 72 65 67 69 73 74 65 72 2d 62 61 74 ge: register-bat
12290 63 68 20 61 63 66 67 20 27 28 28 6b 65 79 31 20 ch acfg '((key1
122a0 2e 20 73 71 6c 31 29 20 28 6b 65 79 32 20 2e 20 . sql1) (key2 .
122b0 73 71 6c 32 29 20 2e 2e 2e 20 29 0a 3b 3b 3b 20 sql2) ... ).;;;
122c0 3b 3b 20 4e 42 2f 2f 20 6f 62 6a 20 69 73 20 6f ;; NB// obj is o
122d0 66 74 65 6e 20 61 6e 20 73 71 6c 20 71 75 65 72 ften an sql quer
122e0 79 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 y.;;; ;;.;;; (de
122f0 66 69 6e 65 20 28 72 65 67 69 73 74 65 72 2d 62 fine (register-b
12300 61 74 63 68 20 61 63 66 67 20 63 74 79 70 65 20 atch acfg ctype
12310 64 61 74 61 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 data).;;; (let
12320 20 28 28 68 74 20 28 61 72 65 61 2d 72 74 61 62 ((ht (area-rtab
12330 6c 65 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 20 le acfg))).;;;
12340 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
12350 28 64 61 74 29 0a 3b 3b 3b 20 09 20 20 20 28 68 (dat).;;; . (h
12360 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 ash-table-set! h
12370 74 20 28 63 61 72 20 64 61 74 29 28 6d 61 6b 65 t (car dat)(make
12380 2d 63 61 6c 6c 64 61 74 20 6f 62 6a 3a 20 28 63 -calldat obj: (c
12390 64 72 20 64 61 74 29 20 63 74 79 70 65 3a 20 63 dr dat) ctype: c
123a0 74 79 70 65 29 29 29 0a 3b 3b 3b 20 09 20 64 61 type))).;;; . da
123b0 74 61 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 ta))).;;; .;;; (
123c0 64 65 66 69 6e 65 20 28 69 6e 69 74 69 61 6c 69 define (initiali
123d0 7a 65 2d 61 72 65 61 2d 63 61 6c 6c 73 2d 66 72 ze-area-calls-fr
123e0 6f 6d 2d 73 70 65 63 66 69 6c 65 20 61 72 65 61 om-specfile area
123f0 20 73 70 65 63 66 69 6c 65 29 0a 3b 3b 3b 20 20 specfile).;;;
12400 20 28 6c 65 74 2a 20 28 28 63 61 6c 6c 73 70 65 (let* ((callspe
12410 63 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 c (with-input-fr
12420 6f 6d 2d 66 69 6c 65 20 73 70 65 63 66 69 6c 65 om-file specfile
12430 20 72 65 61 64 20 29 29 29 0a 3b 3b 3b 20 20 20 read ))).;;;
12440 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
12450 62 64 61 20 28 67 72 6f 75 70 29 0a 3b 3b 3b 20 bda (group).;;;
12460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12470 28 72 65 67 69 73 74 65 72 2d 62 61 74 63 68 0a (register-batch.
12480 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;;
12490 20 20 20 20 20 61 72 65 61 0a 3b 3b 3b 20 20 20 area.;;;
124a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
124b0 63 61 72 20 67 72 6f 75 70 29 0a 3b 3b 3b 20 20 car group).;;;
124c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
124d0 28 63 64 72 20 67 72 6f 75 70 29 29 29 0a 3b 3b (cdr group))).;;
124e0 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
124f0 63 61 6c 6c 73 70 65 63 29 29 29 0a 3b 3b 3b 20 callspec))).;;;
12500 0a 3b 3b 3b 20 3b 3b 20 67 65 74 2d 72 65 6e 74 .;;; ;; get-rent
12510 72 79 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 ry.;;; ;;.;;; (d
12520 65 66 69 6e 65 20 28 67 65 74 2d 72 65 6e 74 72 efine (get-rentr
12530 79 20 61 63 66 67 20 6b 65 79 29 0a 3b 3b 3b 20 y acfg key).;;;
12540 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
12550 66 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d f/default (area-
12560 72 74 61 62 6c 65 20 61 63 66 67 29 20 6b 65 79 rtable acfg) key
12570 20 23 66 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 #f)).;;; .;;; (
12580 64 65 66 69 6e 65 20 28 67 65 74 2d 72 73 71 6c define (get-rsql
12590 20 61 63 66 67 20 6b 65 79 29 0a 3b 3b 3b 20 20 acfg key).;;;
125a0 20 28 6c 65 74 20 28 28 63 64 61 74 20 28 67 65 (let ((cdat (ge
125b0 74 2d 72 65 6e 74 72 79 20 61 63 66 67 20 6b 65 t-rentry acfg ke
125c0 79 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 y))).;;; (if
125d0 20 63 64 61 74 0a 3b 3b 3b 20 09 28 63 61 6c 6c cdat.;;; .(call
125e0 64 61 74 2d 6f 62 6a 20 63 64 61 74 29 0a 3b 3b dat-obj cdat).;;
125f0 3b 20 09 23 66 29 29 29 0a 3b 3b 3b 20 0a 3b 3b ; .#f))).;;; .;;
12600 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 62 ; .;;; .;;; ;; b
12610 6c 6f 63 6b 69 6e 67 20 63 61 6c 6c 3a 0a 3b 3b locking call:.;;
12620 3b 20 3b 3b 20 20 20 20 63 6c 69 65 6e 74 20 20 ; ;; client
12630 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12640 20 20 20 20 20 20 20 73 65 72 76 65 72 0a 3b 3b server.;;
12650 3b 20 3b 3b 20 20 20 20 2d 2d 2d 2d 2d 2d 20 20 ; ;; ------
12660 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12670 20 20 20 20 20 20 20 2d 2d 2d 2d 2d 2d 0a 3b 3b ------.;;
12680 3b 20 3b 3b 20 20 20 20 63 61 6c 6c 28 29 0a 3b ; ;; call().;
12690 3b 3b 20 3b 3b 20 20 20 20 73 65 6e 64 2d 6d 65 ;; ;; send-me
126a0 73 73 61 67 65 28 29 0a 3b 3b 3b 20 3b 3b 20 20 ssage().;;; ;;
126b0 20 20 6e 6d 73 67 2d 73 65 6e 64 28 29 0a 3b 3b nmsg-send().;;
126c0 3b 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ; ;;
126d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
126e0 20 20 20 20 20 20 20 6e 6d 73 67 2d 72 65 63 65 nmsg-rece
126f0 69 76 65 28 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 ive().;;; ;;
12700 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12710 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e n
12720 6d 73 67 2d 72 65 73 70 6f 6e 64 28 61 63 6b 2c msg-respond(ack,
12730 63 6f 6f 6b 69 65 29 0a 3b 3b 3b 20 3b 3b 20 20 cookie).;;; ;;
12740 20 20 61 63 6b 2c 20 63 6f 6f 6b 69 65 0a 3b 3b ack, cookie.;;
12750 3b 20 3b 3b 20 20 20 20 6d 62 6f 78 2d 74 68 72 ; ;; mbox-thr
12760 65 61 64 2d 77 61 69 74 28 63 6f 6f 6b 69 65 29 ead-wait(cookie)
12770 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 20 .;;; ;;
12780 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12790 20 20 20 20 20 20 20 20 20 20 6e 6d 73 67 2d 73 nmsg-s
127a0 65 6e 64 28 63 6c 69 65 6e 74 2c 63 6f 6f 6b 69 end(client,cooki
127b0 65 2c 72 65 73 75 6c 74 29 0a 3b 3b 3b 20 3b 3b e,result).;;; ;;
127c0 20 20 20 20 20 20 20 20 6e 6d 73 67 2d 72 65 73 nmsg-res
127d0 70 6f 6e 64 28 61 63 6b 29 0a 3b 3b 3b 20 3b 3b pond(ack).;;; ;;
127e0 20 20 20 20 20 20 20 20 72 65 74 75 72 6e 20 72 return r
127f0 65 73 75 6c 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b esult.;;; ;;.;;;
12800 20 3b 3b 20 72 65 73 65 72 76 65 64 20 61 63 74 ;; reserved act
12810 69 6f 6e 3a 0a 3b 3b 3b 20 3b 3b 20 20 20 20 27 ion:.;;; ;; '
12820 69 6d 6d 65 64 69 61 74 65 0a 3b 3b 3b 20 3b 3b immediate.;;; ;;
12830 20 20 20 20 27 64 62 69 6e 69 74 73 71 6c 0a 3b 'dbinitsql.;
12840 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e ;; ;;.;;; (defin
12850 65 20 28 63 61 6c 6c 20 61 63 66 67 20 64 62 6e e (call acfg dbn
12860 61 6d 65 20 61 63 74 69 6f 6e 20 70 61 72 61 6d ame action param
12870 73 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 63 6f s #!optional (co
12880 75 6e 74 20 30 29 29 0a 3b 3b 3b 20 20 20 28 6c unt 0)).;;; (l
12890 65 74 2a 20 28 28 63 61 6c 6c 2d 73 74 61 72 74 et* ((call-start
128a0 2d 74 69 6d 65 20 20 20 20 20 28 63 75 72 72 65 -time (curre
128b0 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
128c0 29 0a 3b 3b 3b 20 09 20 28 73 72 76 20 20 20 20 ).;;; . (srv
128d0 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 (ge
128e0 74 2d 62 65 73 74 2d 73 65 72 76 65 72 20 61 63 t-best-server ac
128f0 66 67 20 64 62 6e 61 6d 65 20 61 63 74 69 6f 6e fg dbname action
12900 29 29 0a 3b 3b 3b 20 09 20 28 70 6f 73 74 2d 67 )).;;; . (post-g
12910 65 74 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 63 et-start-time (c
12920 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
12930 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 28 72 64 61 nds)).;;; . (rda
12940 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
12950 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
12960 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d 72 /default (area-r
12970 74 61 62 6c 65 20 61 63 66 67 29 20 61 63 74 69 table acfg) acti
12980 6f 6e 20 23 66 29 29 0a 3b 3b 3b 20 09 20 28 6d on #f)).;;; . (m
12990 79 69 64 20 20 20 20 20 20 20 20 20 20 20 20 20 yid
129a0 20 20 20 28 74 72 69 6d 2d 70 6b 74 69 64 20 28 (trim-pktid (
129b0 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 area-pktid acfg)
129c0 29 29 0a 3b 3b 3b 20 09 20 28 73 72 76 69 64 20 )).;;; . (srvid
129d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
129e0 72 69 6d 2d 70 6b 74 69 64 20 28 61 6c 69 73 74 rim-pktid (alist
129f0 2d 72 65 66 20 27 5a 20 73 72 76 29 29 29 0a 3b -ref 'Z srv))).;
12a00 3b 3b 20 09 20 28 63 6f 6f 6b 69 65 20 20 20 20 ;; . (cookie
12a10 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
12a20 63 6f 6f 6b 69 65 20 6d 79 69 64 29 29 29 0a 3b cookie myid))).;
12a30 3b 3b 20 20 20 20 20 28 73 64 62 67 3e 20 22 63 ;; (sdbg> "c
12a40 61 6c 6c 22 20 22 67 65 74 2d 62 65 73 74 2d 73 all" "get-best-s
12a50 65 72 76 65 72 22 20 63 61 6c 6c 2d 73 74 61 72 erver" call-star
12a60 74 2d 74 69 6d 65 20 23 66 20 63 61 6c 6c 2d 73 t-time #f call-s
12a70 74 61 72 74 2d 74 69 6d 65 20 22 20 66 72 6f 6d tart-time " from
12a80 3a 20 22 20 6d 79 69 64 20 22 20 74 6f 20 73 65 : " myid " to se
12a90 72 76 65 72 3a 20 22 20 73 72 76 69 64 20 22 20 rver: " srvid "
12aa0 66 6f 72 20 22 20 64 62 6e 61 6d 65 20 22 20 61 for " dbname " a
12ab0 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 ction: " action
12ac0 22 20 70 61 72 61 6d 73 3a 20 22 20 70 61 72 61 " params: " para
12ad0 6d 73 20 22 20 72 64 61 74 3a 20 22 20 72 64 61 ms " rdat: " rda
12ae0 74 29 0a 3b 3b 3b 20 20 20 20 20 28 70 72 69 6e t).;;; (prin
12af0 74 20 22 49 4e 46 4f 3a 20 63 61 6c 6c 20 74 6f t "INFO: call to
12b00 20 22 20 28 61 6c 69 73 74 2d 72 65 66 20 27 69 " (alist-ref 'i
12b10 70 61 64 64 72 20 73 72 76 29 20 22 3a 22 20 28 paddr srv) ":" (
12b20 61 6c 69 73 74 2d 72 65 66 20 27 70 6f 72 74 20 alist-ref 'port
12b30 73 72 76 29 20 22 20 66 72 6f 6d 20 22 20 28 61 srv) " from " (a
12b40 72 65 61 2d 6d 79 61 64 64 72 20 61 63 66 67 29 rea-myaddr acfg)
12b50 20 22 3a 22 20 28 61 72 65 61 2d 70 6f 72 74 20 ":" (area-port
12b60 61 63 66 67 29 20 22 20 66 6f 72 20 22 20 64 62 acfg) " for " db
12b70 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 20 20 28 69 name).;;; (i
12b80 66 20 28 61 6e 64 20 73 72 76 20 72 64 61 74 29 f (and srv rdat)
12b90 20 3b 3b 20 6e 65 65 64 20 62 6f 74 68 20 74 6f ;; need both to
12ba0 20 64 69 73 70 61 74 63 68 20 61 20 72 65 71 75 dispatch a requ
12bb0 65 73 74 0a 3b 3b 3b 20 09 28 6c 65 74 2a 20 28 est.;;; .(let* (
12bc0 28 72 69 70 61 64 64 72 20 20 28 61 6c 69 73 74 (ripaddr (alist
12bd0 2d 72 65 66 20 27 69 70 61 64 64 72 20 73 72 76 -ref 'ipaddr srv
12be0 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 )).;;; . (
12bf0 72 73 72 76 69 64 20 20 20 28 61 6c 69 73 74 2d rsrvid (alist-
12c00 72 65 66 20 27 5a 20 73 72 76 29 29 0a 3b 3b 3b ref 'Z srv)).;;;
12c10 20 09 20 20 20 20 20 20 20 28 72 70 6f 72 74 20 . (rport
12c20 20 20 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 (any->number
12c30 28 61 6c 69 73 74 2d 72 65 66 20 27 70 6f 72 74 (alist-ref 'port
12c40 20 20 20 73 72 76 29 29 29 0a 3b 3b 3b 20 09 20 srv))).;;; .
12c50 20 20 20 20 20 20 28 72 65 73 2d 66 75 6c 6c 20 (res-full
12c60 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f (if (and (equal?
12c70 20 72 69 70 61 64 64 72 20 28 61 72 65 61 2d 6d ripaddr (area-m
12c80 79 61 64 64 72 20 61 63 66 67 29 29 0a 3b 3b 3b yaddr acfg)).;;;
12c90 20 09 09 09 09 20 20 28 65 71 75 61 6c 3f 20 72 .... (equal? r
12ca0 70 6f 72 74 20 20 20 28 61 72 65 61 2d 70 6f 72 port (area-por
12cb0 74 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 09 09 t acfg))).;;; ..
12cc0 09 20 20 20 20 20 28 72 65 71 75 65 73 74 20 61 . (request a
12cd0 63 66 67 20 72 69 70 61 64 64 72 20 72 70 6f 72 cfg ripaddr rpor
12ce0 74 20 28 61 72 65 61 2d 70 6b 74 69 64 20 61 63 t (area-pktid ac
12cf0 66 67 29 20 61 63 74 69 6f 6e 20 63 6f 6f 6b 69 fg) action cooki
12d00 65 20 64 62 6e 61 6d 65 20 70 61 72 61 6d 73 29 e dbname params)
12d10 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 73 61 .;;; ... (sa
12d20 66 65 2d 63 61 6c 6c 20 27 72 65 71 75 65 73 74 fe-call 'request
12d30 20 72 69 70 61 64 64 72 20 72 70 6f 72 74 0a 3b ripaddr rport.;
12d40 3b 3b 20 09 09 09 09 09 28 61 72 65 61 2d 6d 79 ;; .....(area-my
12d50 61 64 64 72 20 61 63 66 67 29 0a 3b 3b 3b 20 09 addr acfg).;;; .
12d60 09 09 09 09 28 61 72 65 61 2d 70 6f 72 74 20 20 ....(area-port
12d70 20 61 63 66 67 29 0a 3b 3b 3b 20 09 09 09 09 09 acfg).;;; .....
12d80 23 3b 28 61 72 65 61 2d 70 6b 74 69 64 20 61 63 #;(area-pktid ac
12d90 66 67 29 0a 3b 3b 3b 20 09 09 09 09 09 72 73 72 fg).;;; .....rsr
12da0 76 69 64 0a 3b 3b 3b 20 09 09 09 09 09 61 63 74 vid.;;; .....act
12db0 69 6f 6e 20 63 6f 6f 6b 69 65 20 64 62 6e 61 6d ion cookie dbnam
12dc0 65 20 70 61 72 61 6d 73 29 29 29 29 0a 3b 3b 3b e params)))).;;;
12dd0 20 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 . ;; (print "r
12de0 65 73 2d 66 75 6c 6c 3a 20 22 20 72 65 73 2d 66 es-full: " res-f
12df0 75 6c 6c 29 0a 3b 3b 3b 20 09 20 20 28 6d 61 74 ull).;;; . (mat
12e00 63 68 20 72 65 73 2d 66 75 6c 6c 0a 3b 3b 3b 20 ch res-full.;;;
12e10 09 20 20 20 20 28 28 72 65 73 70 6f 6e 73 65 2d . ((response-
12e20 6f 6b 20 72 65 73 70 6f 6e 73 65 2d 6d 73 67 20 ok response-msg
12e30 72 65 6d 20 2e 2e 2e 29 0a 3b 3b 3b 20 09 20 20 rem ...).;;; .
12e40 20 20 20 28 6c 65 74 2a 20 28 28 73 65 6e 64 2d (let* ((send-
12e50 6d 65 73 73 61 67 65 2d 74 69 6d 65 20 28 63 75 message-time (cu
12e60 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
12e70 64 73 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 3b ds)).;;; .. ;
12e80 3b 20 28 6d 61 74 63 68 20 72 65 73 2d 66 75 6c ; (match res-ful
12e90 6c 0a 3b 3b 3b 20 09 09 20 20 20 20 3b 3b 20 20 l.;;; .. ;;
12ea0 28 28 72 65 73 70 6f 6e 73 65 2d 6f 6b 20 72 65 ((response-ok re
12eb0 73 70 6f 6e 73 65 2d 6d 73 67 29 0a 3b 3b 3b 20 sponse-msg).;;;
12ec0 09 09 20 20 20 20 3b 3b 20 28 72 65 73 70 6f 6e .. ;; (respon
12ed0 73 65 2d 6f 6b 20 20 28 63 61 72 20 72 65 73 2d se-ok (car res-
12ee0 66 75 6c 6c 29 29 0a 3b 3b 3b 20 09 09 20 20 20 full)).;;; ..
12ef0 20 3b 3b 20 28 72 65 73 70 6f 6e 73 65 2d 6d 73 ;; (response-ms
12f00 67 20 28 63 61 64 72 20 72 65 73 2d 66 75 6c 6c g (cadr res-full
12f10 29 0a 3b 3b 3b 20 09 09 20 20 20 20 29 0a 3b 3b ).;;; .. ).;;
12f20 3b 20 09 20 20 20 20 20 20 20 3b 3b 20 28 72 65 ; . ;; (re
12f30 73 20 28 74 61 6b 65 20 72 65 73 2d 66 75 6c 6c s (take res-full
12f40 20 33 29 29 29 20 3b 3b 20 63 74 79 70 65 20 3d 3))) ;; ctype =
12f50 3d 20 61 63 74 69 6f 6e 2c 20 54 4f 44 4f 3a 20 = action, TODO:
12f60 63 6f 6e 76 65 72 67 65 20 6f 6e 20 6f 6e 65 20 converge on one
12f70 74 65 72 6d 20 3c 3c 3d 3d 3d 20 77 68 61 74 20 term <<=== what
12f80 77 61 73 20 74 68 69 73 3f 20 42 55 47 20 0a 3b was this? BUG .;
12f90 3b 3b 20 09 20 20 20 20 20 20 20 3b 3b 20 28 70 ;; . ;; (p
12fa0 72 69 6e 74 20 22 75 6c 65 78 3a 63 61 6c 6c 3a rint "ulex:call:
12fb0 20 73 65 6e 64 2d 6d 65 73 73 61 67 65 20 74 6f send-message to
12fc0 6f 6b 20 22 20 28 2d 20 73 65 6e 64 2d 6d 65 73 ok " (- send-mes
12fd0 73 61 67 65 2d 74 69 6d 65 20 70 6f 73 74 2d 67 sage-time post-g
12fe0 65 74 2d 73 74 61 72 74 2d 74 69 6d 65 29 20 22 et-start-time) "
12ff0 20 6d 73 20 70 61 72 61 6d 73 3d 22 20 70 61 72 ms params=" par
13000 61 6d 73 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 ams).;;; .
13010 20 28 73 64 62 67 3e 20 22 63 61 6c 6c 22 20 22 (sdbg> "call" "
13020 73 65 6e 64 2d 6d 65 73 73 61 67 65 22 20 70 6f send-message" po
13030 73 74 2d 67 65 74 2d 73 74 61 72 74 2d 74 69 6d st-get-start-tim
13040 65 20 23 66 20 63 61 6c 6c 2d 73 74 61 72 74 2d e #f call-start-
13050 74 69 6d 65 29 0a 3b 3b 3b 20 09 20 20 20 20 20 time).;;; .
13060 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 09 09 28 28 (cond.;;; ..((
13070 6e 6f 74 20 72 65 73 70 6f 6e 73 65 2d 6f 6b 29 not response-ok)
13080 20 23 66 29 0a 3b 3b 3b 20 09 09 28 28 6d 65 6d #f).;;; ..((mem
13090 62 65 72 20 72 65 73 70 6f 6e 73 65 2d 6d 73 67 ber response-msg
130a0 20 27 28 22 64 62 20 72 65 61 64 20 73 75 62 6d '("db read subm
130b0 69 74 74 65 64 22 20 22 64 62 20 77 72 69 74 65 itted" "db write
130c0 20 73 75 62 6d 69 74 74 65 64 22 29 29 0a 3b 3b submitted")).;;
130d0 3b 20 09 09 20 28 6c 65 74 2a 20 28 28 63 6f 6f ; .. (let* ((coo
130e0 6b 69 65 2d 69 64 20 20 20 28 63 61 64 64 64 72 kie-id (cadddr
130f0 20 72 65 73 2d 66 75 6c 6c 29 29 0a 3b 3b 3b 20 res-full)).;;;
13100 09 09 09 28 6d 62 6f 78 20 20 20 20 20 20 20 20 ...(mbox
13110 28 6d 61 6b 65 2d 6d 61 69 6c 62 6f 78 29 29 0a (make-mailbox)).
13120 3b 3b 3b 20 09 09 09 28 6d 62 6f 78 2d 74 69 6d ;;; ...(mbox-tim
13130 65 20 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c e (current-mil
13140 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b liseconds))).;;;
13150 20 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c .. (hash-tabl
13160 65 2d 73 65 74 21 20 28 61 72 65 61 2d 63 6f 6f e-set! (area-coo
13170 6b 69 65 32 6d 62 6f 78 20 61 63 66 67 29 20 63 kie2mbox acfg) c
13180 6f 6f 6b 69 65 2d 69 64 20 6d 62 6f 78 29 0a 3b ookie-id mbox).;
13190 3b 3b 20 09 09 20 20 20 28 6c 65 74 2a 20 28 28 ;; .. (let* ((
131a0 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d 73 65 63 mbox-timeout-sec
131b0 73 20 20 20 20 32 30 29 0a 3b 3b 3b 20 09 09 09 s 20).;;; ...
131c0 20 20 28 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d (mbox-timeout-
131d0 72 65 73 75 6c 74 20 27 4d 42 4f 58 5f 54 49 4d result 'MBOX_TIM
131e0 45 4f 55 54 29 0a 3b 3b 3b 20 09 09 09 20 20 28 EOUT).;;; ... (
131f0 72 65 73 20 20 20 20 20 20 20 20 20 20 20 20 20 res
13200 20 20 20 20 20 28 6d 61 69 6c 62 6f 78 2d 72 65 (mailbox-re
13210 63 65 69 76 65 21 20 6d 62 6f 78 20 6d 62 6f 78 ceive! mbox mbox
13220 2d 74 69 6d 65 6f 75 74 2d 73 65 63 73 20 6d 62 -timeout-secs mb
13230 6f 78 2d 74 69 6d 65 6f 75 74 2d 72 65 73 75 6c ox-timeout-resul
13240 74 29 29 0a 3b 3b 3b 20 09 09 09 20 20 28 6d 62 t)).;;; ... (mb
13250 6f 78 2d 72 65 63 65 69 76 65 2d 74 69 6d 65 20 ox-receive-time
13260 20 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (current-mill
13270 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 iseconds))).;;;
13280 09 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
13290 6c 65 2d 64 65 6c 65 74 65 21 20 28 61 72 65 61 le-delete! (area
132a0 2d 63 6f 6f 6b 69 65 32 6d 62 6f 78 20 61 63 66 -cookie2mbox acf
132b0 67 29 20 63 6f 6f 6b 69 65 2d 69 64 29 0a 3b 3b g) cookie-id).;;
132c0 3b 20 09 09 20 20 20 20 20 28 73 64 62 67 3e 20 ; .. (sdbg>
132d0 22 63 61 6c 6c 22 20 22 6d 61 69 6c 62 6f 78 2d "call" "mailbox-
132e0 72 65 63 65 69 76 65 22 20 6d 62 6f 78 2d 74 69 receive" mbox-ti
132f0 6d 65 20 23 66 20 63 61 6c 6c 2d 73 74 61 72 74 me #f call-start
13300 2d 74 69 6d 65 20 22 20 66 72 6f 6d 3a 20 22 20 -time " from: "
13310 6d 79 69 64 20 22 20 74 6f 20 73 65 72 76 65 72 myid " to server
13320 3a 20 22 20 73 72 76 69 64 20 22 20 66 6f 72 20 : " srvid " for
13330 22 20 64 62 6e 61 6d 65 29 0a 3b 3b 3b 20 09 09 " dbname).;;; ..
13340 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
13350 75 6c 65 78 3a 63 61 6c 6c 20 6d 61 69 6c 62 6f ulex:call mailbo
13360 78 2d 72 65 63 65 69 76 65 20 74 6f 6f 6b 20 22 x-receive took "
13370 20 28 2d 20 6d 62 6f 78 2d 72 65 63 65 69 76 65 (- mbox-receive
13380 2d 74 69 6d 65 20 6d 62 6f 78 2d 74 69 6d 65 29 -time mbox-time)
13390 20 22 6d 73 20 70 61 72 61 6d 73 3d 22 20 70 61 "ms params=" pa
133a0 72 61 6d 73 29 0a 3b 3b 3b 20 09 09 20 20 20 20 rams).;;; ..
133b0 20 72 65 73 29 29 29 0a 3b 3b 3b 20 09 09 28 65 res))).;;; ..(e
133c0 6c 73 65 0a 3b 3b 3b 20 09 09 20 28 70 72 69 6e lse.;;; .. (prin
133d0 74 20 22 55 6e 68 61 6e 64 6c 65 64 20 72 65 73 t "Unhandled res
133e0 70 6f 6e 73 65 20 5c 22 22 72 65 73 70 6f 6e 73 ponse \""respons
133f0 65 2d 6d 73 67 22 5c 22 22 29 0a 3b 3b 3b 20 09 e-msg"\"").;;; .
13400 09 20 23 66 29 29 0a 3b 3b 3b 20 09 20 20 20 20 . #f)).;;; .
13410 20 20 20 3b 3b 20 64 65 70 65 6e 64 69 6e 67 20 ;; depending
13420 6f 6e 20 77 68 61 74 20 61 63 74 69 6f 6e 20 28 on what action (
13430 69 2e 65 2e 20 63 74 79 70 65 29 20 69 73 20 77 i.e. ctype) is w
13440 65 20 77 69 6c 6c 20 62 6c 6f 63 6b 20 68 65 72 e will block her
13450 65 20 77 61 69 74 69 6e 67 20 66 6f 72 0a 3b 3b e waiting for.;;
13460 3b 20 09 20 20 20 20 20 20 20 3b 3b 20 61 6c 6c ; . ;; all
13470 20 74 68 65 20 64 61 74 61 20 28 6d 65 63 68 61 the data (mecha
13480 6e 69 73 6d 20 74 6f 20 62 65 20 64 65 74 65 72 nism to be deter
13490 6d 69 6e 65 64 29 0a 3b 3b 3b 20 09 20 20 20 20 mined).;;; .
134a0 20 20 20 3b 3b 0a 3b 3b 3b 20 09 20 20 20 20 20 ;;.;;; .
134b0 20 20 3b 3b 20 69 66 20 72 65 73 20 69 73 20 61 ;; if res is a
134c0 20 22 77 6f 72 6b 69 6e 67 20 6f 6e 20 69 74 22 "working on it"
134d0 20 74 68 65 6e 20 77 61 69 74 0a 3b 3b 3b 20 09 then wait.;;; .
134e0 20 20 20 20 20 20 20 3b 3b 20 20 20 20 77 61 69 ;; wai
134f0 74 20 66 6f 72 20 72 65 73 75 6c 74 0a 3b 3b 3b t for result.;;;
13500 20 09 20 20 20 20 20 20 20 3b 3b 20 6d 61 69 6c . ;; mail
13510 62 6f 78 20 74 68 72 65 61 64 20 77 61 69 74 20 box thread wait
13520 6f 6e 20 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 on .;;; .
13530 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 3b 3b 20 .;;; . ;;
13540 69 66 20 72 65 73 20 69 73 20 61 20 22 63 61 6e if res is a "can
13550 27 74 20 68 65 6c 70 20 79 6f 75 22 20 74 68 65 't help you" the
13560 6e 20 74 72 79 20 61 20 64 69 66 66 65 72 65 6e n try a differen
13570 74 20 73 65 72 76 65 72 0a 3b 3b 3b 20 09 20 20 t server.;;; .
13580 20 20 20 20 20 3b 3b 20 69 66 20 72 65 73 20 69 ;; if res i
13590 73 20 61 20 22 61 63 6b 22 20 28 65 2e 67 2e 20 s a "ack" (e.g.
135a0 66 6f 72 20 6f 6e 65 2d 73 68 6f 74 20 72 65 71 for one-shot req
135b0 75 65 73 74 73 29 20 74 68 65 6e 20 72 65 74 75 uests) then retu
135c0 72 6e 20 72 65 73 0a 3b 3b 3b 20 09 20 20 20 20 rn res.;;; .
135d0 20 20 20 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 )).;;; . (
135e0 65 6c 73 65 0a 3b 3b 3b 20 09 20 20 20 20 20 28 else.;;; . (
135f0 69 66 20 28 3c 20 63 6f 75 6e 74 20 31 30 29 0a if (< count 10).
13600 3b 3b 3b 20 09 09 20 28 6c 65 74 2a 20 28 28 75 ;;; .. (let* ((u
13610 72 6c 20 28 63 6f 6e 63 20 28 61 6c 69 73 74 2d rl (conc (alist-
13620 72 65 66 20 27 69 70 61 64 64 72 20 73 72 76 29 ref 'ipaddr srv)
13630 20 22 3a 22 20 28 61 6c 69 73 74 2d 72 65 66 20 ":" (alist-ref
13640 27 70 6f 72 74 20 73 72 76 29 29 29 29 0a 3b 3b 'port srv)))).;;
13650 3b 20 09 09 20 20 20 28 74 68 72 65 61 64 2d 73 ; .. (thread-s
13660 6c 65 65 70 21 20 31 29 0a 3b 3b 3b 20 09 09 20 leep! 1).;;; ..
13670 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
13680 20 42 61 64 20 72 65 73 75 6c 74 20 66 72 6f 6d Bad result from
13690 20 22 20 75 72 6c 20 22 2c 20 64 62 6e 61 6d 65 " url ", dbname
136a0 3a 20 22 20 64 62 6e 61 6d 65 20 22 2c 20 61 63 : " dbname ", ac
136b0 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 tion: " action "
136c0 2c 20 70 61 72 61 6d 73 3a 20 22 20 70 61 72 61 , params: " para
136d0 6d 73 20 22 2e 20 54 72 79 69 6e 67 20 61 67 61 ms ". Trying aga
136e0 69 6e 20 69 6e 20 31 20 73 65 63 6f 6e 64 2e 22 in in 1 second."
136f0 29 0a 3b 3b 3b 20 09 09 20 20 20 28 63 61 6c 6c ).;;; .. (call
13700 20 61 63 66 67 20 64 62 6e 61 6d 65 20 61 63 74 acfg dbname act
13710 69 6f 6e 20 70 61 72 61 6d 73 20 28 2b 20 63 6f ion params (+ co
13720 75 6e 74 20 31 29 29 29 0a 3b 3b 3b 20 09 09 20 unt 1))).;;; ..
13730 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 (begin.;;; ..
13740 28 65 72 72 6f 72 20 28 63 6f 6e 63 20 22 45 52 (error (conc "ER
13750 52 4f 52 3a 20 22 20 63 6f 75 6e 74 20 22 20 74 ROR: " count " t
13760 72 69 65 73 2c 20 73 74 69 6c 6c 20 68 61 76 65 ries, still have
13770 20 69 6d 70 72 6f 70 65 72 20 72 65 73 70 6f 6e improper respon
13780 73 65 20 72 65 73 2d 66 75 6c 6c 3d 22 20 72 65 se res-full=" re
13790 73 2d 66 75 6c 6c 29 29 29 29 29 29 29 0a 3b 3b s-full))))))).;;
137a0 3b 20 09 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 ; .(begin.;;; .
137b0 20 28 69 66 20 28 6e 6f 74 20 72 64 61 74 29 0a (if (not rdat).
137c0 3b 3b 3b 20 09 20 20 20 20 20 20 28 70 72 69 6e ;;; . (prin
137d0 74 20 22 45 52 52 4f 52 3a 20 61 63 74 69 6f 6e t "ERROR: action
137e0 20 22 20 61 63 74 69 6f 6e 20 22 20 6e 6f 74 20 " action " not
137f0 72 65 67 69 73 74 65 72 65 64 2e 22 29 0a 3b 3b registered.").;;
13800 3b 20 09 20 20 20 20 20 20 28 69 66 20 28 3c 20 ; . (if (<
13810 63 6f 75 6e 74 20 31 30 29 0a 3b 3b 3b 20 09 09 count 10).;;; ..
13820 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 (begin.;;; ..
13830 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
13840 31 29 0a 3b 3b 3b 20 09 09 20 20 20 28 61 72 65 1).;;; .. (are
13850 61 2d 68 6f 73 74 73 2d 73 65 74 21 20 61 63 66 a-hosts-set! acf
13860 67 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 g (make-hash-tab
13870 6c 65 29 29 20 3b 3b 20 63 6c 65 61 72 20 6f 75 le)) ;; clear ou
13880 74 20 61 6c 6c 20 6b 6e 6f 77 6e 20 68 6f 73 74 t all known host
13890 73 0a 3b 3b 3b 20 09 09 20 20 20 28 70 72 69 6e s.;;; .. (prin
138a0 74 20 22 45 52 52 4f 52 3a 20 6e 6f 20 73 65 72 t "ERROR: no ser
138b0 76 65 72 20 66 6f 75 6e 64 2c 20 73 72 76 3d 22 ver found, srv="
138c0 20 73 72 76 20 22 2c 20 74 72 79 69 6e 67 20 61 srv ", trying a
138d0 67 61 69 6e 20 69 6e 20 31 20 73 65 63 6f 6e 64 gain in 1 second
138e0 73 22 29 0a 3b 3b 3b 20 09 09 20 20 20 28 63 61 s").;;; .. (ca
138f0 6c 6c 20 61 63 66 67 20 64 62 6e 61 6d 65 20 61 ll acfg dbname a
13900 63 74 69 6f 6e 20 70 61 72 61 6d 73 20 28 2b 20 ction params (+
13910 63 6f 75 6e 74 20 31 29 29 29 0a 3b 3b 3b 20 09 count 1))).;;; .
13920 09 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 . (begin.;;; ..
13930 20 20 28 65 72 72 6f 72 20 28 63 6f 6e 63 20 22 (error (conc "
13940 45 52 52 4f 52 3a 20 6e 6f 20 73 65 72 76 65 72 ERROR: no server
13950 20 66 6f 75 6e 64 20 61 66 74 65 72 20 31 30 20 found after 10
13960 74 72 69 65 73 2c 20 73 72 76 3d 22 20 73 72 76 tries, srv=" srv
13970 20 22 2c 20 67 69 76 69 6e 67 20 75 70 2e 22 29 ", giving up.")
13980 29 0a 3b 3b 3b 20 09 09 20 20 20 23 3b 28 65 72 ).;;; .. #;(er
13990 72 6f 72 20 22 4e 6f 20 73 65 72 76 65 72 20 61 ror "No server a
139a0 76 61 69 6c 61 62 6c 65 22 29 29 29 29 29 29 29 vailable")))))))
139b0 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 ).;;; .;;; .;;;
139c0 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
139f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a00 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 ========.;;; ;;
13a10 55 20 54 20 49 20 4c 20 49 20 54 20 49 20 45 20 U T I L I T I E
13a20 53 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d S .;;; ;;=======
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 3d ================
13a50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
13a70 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 67 65 74 20 ;;; .;;; ;; get
13a80 61 20 73 69 67 6e 61 74 75 72 65 20 66 6f 72 20 a signature for
13a90 69 64 65 6e 74 69 66 69 6e 67 20 74 68 69 73 20 identifing this
13aa0 70 72 6f 63 65 73 73 0a 3b 3b 3b 20 3b 3b 0a 3b process.;;; ;;.;
13ab0 3b 3b 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d ;; (define (get-
13ac0 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 74 75 72 process-signatur
13ad0 65 29 0a 3b 3b 3b 20 20 20 28 63 6f 6e 73 20 28 e).;;; (cons (
13ae0 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 28 63 get-host-name)(c
13af0 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
13b00 64 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b d))).;;; .;;; ;;
13b10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b50 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 53 20 ======.;;; ;; S
13b60 59 20 53 20 54 20 45 20 4d 20 20 20 53 20 54 20 Y S T E M S T
13b70 55 20 46 20 46 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d U F F.;;; ;;====
13b80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13ba0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13bb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13bc0 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 67 ==.;;; .;;; ;; g
13bd0 65 74 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 et normalized cp
13be0 75 20 6c 6f 61 64 20 62 79 20 72 65 61 64 69 6e u load by readin
13bf0 67 20 66 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 g from /proc/loa
13c00 64 61 76 67 20 61 6e 64 0a 3b 3b 3b 20 3b 3b 20 davg and.;;; ;;
13c10 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 20 72 65 /proc/cpuinfo re
13c20 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 76 turn all three v
13c30 61 6c 75 65 73 20 61 6e 64 20 74 68 65 20 6e 75 alues and the nu
13c40 6d 62 65 72 20 6f 66 20 72 65 61 6c 20 63 70 75 mber of real cpu
13c50 73 0a 3b 3b 3b 20 3b 3b 20 61 6e 64 20 74 68 65 s.;;; ;; and the
13c60 20 6e 75 6d 62 65 72 20 6f 66 20 74 68 72 65 61 number of threa
13c70 64 73 20 72 65 74 75 72 6e 73 20 61 6c 69 73 74 ds returns alist
13c80 20 27 28 28 61 64 6a 2d 63 70 75 2d 6c 6f 61 64 '((adj-cpu-load
13c90 0a 3b 3b 3b 20 3b 3b 20 2e 20 6e 6f 72 6d 61 6c .;;; ;; . normal
13ca0 69 7a 65 64 2d 70 72 6f 63 2d 6c 6f 61 64 29 20 ized-proc-load)
13cb0 2e 2e 2e 20 65 74 63 2e 20 20 6b 65 79 73 3a 20 ... etc. keys:
13cc0 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 2c 0a 3b adj-proc-load,.;
13cd0 3b 3b 20 3b 3b 20 61 64 6a 2d 63 6f 72 65 2d 6c ;; ;; adj-core-l
13ce0 6f 61 64 2c 20 31 6d 2d 6c 6f 61 64 2c 20 35 6d oad, 1m-load, 5m
13cf0 2d 6c 6f 61 64 2c 20 31 35 6d 2d 6c 6f 61 64 0a -load, 15m-load.
13d00 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 ;;; ;;.;;; (defi
13d10 6e 65 20 28 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a ne (get-normaliz
13d20 65 64 2d 63 70 75 2d 6c 6f 61 64 29 0a 3b 3b 3b ed-cpu-load).;;;
13d30 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 67 (let ((res (g
13d40 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 et-normalized-cp
13d50 75 2d 6c 6f 61 64 2d 72 61 77 29 29 0a 3b 3b 3b u-load-raw)).;;;
13d60 20 09 28 64 65 66 61 75 6c 74 20 60 28 28 61 64 .(default `((ad
13d70 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 2e 20 32 29 j-proc-load . 2)
13d80 20 3b 3b 20 74 68 65 72 65 20 69 73 20 6e 6f 20 ;; there is no
13d90 72 69 67 68 74 20 61 6e 73 77 65 72 0a 3b 3b 3b right answer.;;;
13da0 20 09 09 20 20 20 28 61 64 6a 2d 63 6f 72 65 2d .. (adj-core-
13db0 6c 6f 61 64 20 2e 20 32 29 0a 3b 3b 3b 20 09 09 load . 2).;;; ..
13dc0 20 20 20 28 31 6d 2d 6c 6f 61 64 20 20 20 20 20 (1m-load
13dd0 20 20 2e 20 32 29 0a 3b 3b 3b 20 09 09 20 20 20 . 2).;;; ..
13de0 28 35 6d 2d 6c 6f 61 64 20 20 20 20 20 20 20 2e (5m-load .
13df0 20 30 29 20 3b 3b 20 63 61 75 73 65 73 20 61 20 0) ;; causes a
13e00 6c 61 72 67 65 20 64 65 6c 74 61 20 2d 20 74 68 large delta - th
13e10 75 73 20 63 61 75 73 69 6e 67 20 64 65 66 61 75 us causing defau
13e20 6c 74 20 6f 66 20 74 68 72 6f 74 74 6c 69 6e 67 lt of throttling
13e30 20 69 66 20 73 74 75 66 66 20 67 6f 65 73 20 77 if stuff goes w
13e40 72 6f 6e 67 0a 3b 3b 3b 20 09 09 20 20 20 28 31 rong.;;; .. (1
13e50 35 6d 2d 6c 6f 61 64 20 20 20 20 20 20 2e 20 30 5m-load . 0
13e60 29 0a 3b 3b 3b 20 09 09 20 20 20 28 70 72 6f 63 ).;;; .. (proc
13e70 20 20 20 20 20 20 20 20 20 20 2e 20 31 29 0a 3b . 1).;
13e80 3b 3b 20 09 09 20 20 20 28 63 6f 72 65 20 20 20 ;; .. (core
13e90 20 20 20 20 20 20 20 2e 20 31 29 0a 3b 3b 3b 20 . 1).;;;
13ea0 09 09 20 20 20 28 70 68 79 73 20 20 20 20 20 20 .. (phys
13eb0 20 20 20 20 2e 20 31 29 0a 3b 3b 3b 20 09 09 20 . 1).;;; ..
13ec0 20 20 28 65 72 72 6f 72 20 20 20 20 20 20 20 20 (error
13ed0 20 2e 20 23 74 29 29 29 29 0a 3b 3b 3b 20 20 20 . #t)))).;;;
13ee0 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 20 20 20 20 (cond.;;;
13ef0 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 72 65 ((and (list? re
13f00 73 29 0a 3b 3b 3b 20 09 20 20 20 28 3e 20 28 6c s).;;; . (> (l
13f10 65 6e 67 74 68 20 72 65 73 29 20 32 29 29 0a 3b ength res) 2)).;
13f20 3b 3b 20 20 20 20 20 20 20 72 65 73 29 0a 3b 3b ;; res).;;
13f30 3b 20 20 20 20 20 20 28 28 65 71 3f 20 72 65 73 ; ((eq? res
13f40 20 23 66 29 20 20 20 64 65 66 61 75 6c 74 29 20 #f) default)
13f50 3b 3b 20 61 64 64 20 6d 65 73 73 61 67 65 73 3f ;; add messages?
13f60 0a 3b 3b 3b 20 20 20 20 20 20 28 28 65 71 3f 20 .;;; ((eq?
13f70 72 65 73 20 23 66 29 20 64 65 66 61 75 6c 74 29 res #f) default)
13f80 20 20 20 3b 3b 20 74 68 69 73 20 77 6f 75 6c 64 ;; this would
13f90 20 62 65 20 74 68 65 20 23 65 6f 66 0a 3b 3b 3b be the #eof.;;;
13fa0 20 20 20 20 20 20 28 65 6c 73 65 20 64 65 66 61 (else defa
13fb0 75 6c 74 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b ult)))).;;; .;;;
13fc0 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6e 6f (define (get-no
13fd0 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 rmalized-cpu-loa
13fe0 64 2d 72 61 77 29 0a 3b 3b 3b 20 20 20 28 6c 65 d-raw).;;; (le
13ff0 74 2a 20 28 28 61 63 74 75 61 6c 2d 68 6f 73 74 t* ((actual-host
14000 20 20 20 20 20 20 20 20 20 20 20 28 67 65 74 2d (get-
14010 68 6f 73 74 2d 6e 61 6d 65 29 29 29 20 3b 3b 20 host-name))) ;;
14020 23 66 20 69 73 20 6c 6f 63 61 6c 68 6f 73 74 0a #f is localhost.
14030 3b 3b 3b 20 20 20 20 20 28 6c 65 74 20 28 28 64 ;;; (let ((d
14040 61 74 61 20 20 28 61 70 70 65 6e 64 20 0a 3b 3b ata (append .;;
14050 3b 20 09 09 20 20 28 77 69 74 68 2d 69 6e 70 75 ; .. (with-inpu
14060 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 t-from-file "/pr
14070 6f 63 2f 6c 6f 61 64 61 76 67 22 20 72 65 61 64 oc/loadavg" read
14080 2d 6c 69 6e 65 73 29 0a 3b 3b 3b 20 09 09 20 20 -lines).;;; ..
14090 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
140a0 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 63 70 75 -file "/proc/cpu
140b0 69 6e 66 6f 22 20 72 65 61 64 2d 6c 69 6e 65 73 info" read-lines
140c0 29 0a 3b 3b 3b 20 09 09 20 20 28 6c 69 73 74 20 ).;;; .. (list
140d0 22 65 6e 64 22 29 29 29 0a 3b 3b 3b 20 09 20 20 "end"))).;;; .
140e0 28 6c 6f 61 64 2d 72 78 20 20 28 72 65 67 65 78 (load-rx (regex
140f0 70 20 22 5e 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c p "^([\\d\\.]+)\
14100 5c 73 2b 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c \s+([\\d\\.]+)\\
14110 73 2b 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 s+([\\d\\.]+)\\s
14120 2b 2e 2a 24 22 29 29 0a 3b 3b 3b 20 09 20 20 28 +.*$")).;;; . (
14130 70 72 6f 63 2d 72 78 20 20 28 72 65 67 65 78 70 proc-rx (regexp
14140 20 22 5e 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b "^processor\\s+
14150 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 :\\s+(\\d+)\\s*$
14160 22 29 29 0a 3b 3b 3b 20 09 20 20 28 63 6f 72 65 ")).;;; . (core
14170 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 63 -rx (regexp "^c
14180 6f 72 65 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 ore id\\s+:\\s+(
14190 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 3b 3b \\d+)\\s*$")).;;
141a0 3b 20 09 20 20 28 70 68 79 73 2d 72 78 20 20 28 ; . (phys-rx (
141b0 72 65 67 65 78 70 20 22 5e 70 68 79 73 69 63 61 regexp "^physica
141c0 6c 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c l id\\s+:\\s+(\\
141d0 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 3b 3b 3b 20 d+)\\s*$")).;;;
141e0 09 20 20 28 6d 61 78 2d 6e 75 6d 20 20 28 6c 61 . (max-num (la
141f0 6d 62 64 61 20 28 70 20 6e 29 28 6d 61 78 20 28 mbda (p n)(max (
14200 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 string->number p
14210 29 20 6e 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 ) n)))).;;;
14220 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 64 61 74 ;; (print "dat
14230 61 3d 22 20 64 61 74 61 29 0a 3b 3b 3b 20 20 20 a=" data).;;;
14240 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 (if (null? d
14250 61 74 61 29 20 3b 3b 20 73 6f 6d 65 74 68 69 6e ata) ;; somethin
14260 67 20 77 65 6e 74 20 77 72 6f 6e 67 0a 3b 3b 3b g went wrong.;;;
14270 20 09 20 20 23 66 0a 3b 3b 3b 20 09 20 20 28 6c . #f.;;; . (l
14280 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 et loop ((hed
14290 20 20 20 28 63 61 72 20 64 61 74 61 29 29 0a 3b (car data)).;
142a0 3b 3b 20 09 09 20 20 20 20 20 28 74 61 6c 20 20 ;; .. (tal
142b0 20 20 20 20 28 63 64 72 20 64 61 74 61 29 29 0a (cdr data)).
142c0 3b 3b 3b 20 09 09 20 20 20 20 20 28 6c 6f 61 64 ;;; .. (load
142d0 73 20 20 20 20 23 66 29 0a 3b 3b 3b 20 09 09 20 s #f).;;; ..
142e0 20 20 20 20 28 70 72 6f 63 2d 6e 75 6d 20 30 29 (proc-num 0)
142f0 20 20 3b 3b 20 70 72 6f 63 65 73 73 6f 72 20 69 ;; processor i
14300 6e 63 6c 75 64 65 73 20 74 68 72 65 61 64 73 0a ncludes threads.
14310 3b 3b 3b 20 09 09 20 20 20 20 20 28 70 68 79 73 ;;; .. (phys
14320 2d 6e 75 6d 20 30 29 20 20 3b 3b 20 70 68 79 73 -num 0) ;; phys
14330 69 63 61 6c 20 63 68 69 70 20 6f 6e 20 6d 6f 74 ical chip on mot
14340 68 65 72 62 6f 61 72 64 0a 3b 3b 3b 20 09 09 20 herboard.;;; ..
14350 20 20 20 20 28 63 6f 72 65 2d 6e 75 6d 20 30 29 (core-num 0)
14360 29 20 3b 3b 20 63 6f 72 65 0a 3b 3b 3b 20 09 20 ) ;; core.;;; .
14370 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 68 65 64 ;; (print hed
14380 20 22 2c 20 22 20 6c 6f 61 64 73 20 22 2c 20 22 ", " loads ", "
14390 20 70 72 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 70 proc-num ", " p
143a0 68 79 73 2d 6e 75 6d 20 22 2c 20 22 20 63 6f 72 hys-num ", " cor
143b0 65 2d 6e 75 6d 29 0a 3b 3b 3b 20 09 20 20 20 20 e-num).;;; .
143c0 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 (if (null? tal)
143d0 3b 3b 20 68 61 76 65 20 61 6c 6c 20 6f 75 72 20 ;; have all our
143e0 64 61 74 61 2c 20 63 61 6c 63 75 6c 61 74 65 20 data, calculate
143f0 6e 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 20 normalized load
14400 61 6e 64 20 72 65 74 75 72 6e 20 72 65 73 75 6c and return resul
14410 74 0a 3b 3b 3b 20 09 09 28 6c 65 74 2a 20 28 28 t.;;; ..(let* ((
14420 61 63 74 2d 70 72 6f 63 20 28 2b 20 70 72 6f 63 act-proc (+ proc
14430 2d 6e 75 6d 20 31 29 29 0a 3b 3b 3b 20 09 09 20 -num 1)).;;; ..
14440 20 20 20 20 20 20 28 61 63 74 2d 70 68 79 73 20 (act-phys
14450 28 2b 20 70 68 79 73 2d 6e 75 6d 20 31 29 29 0a (+ phys-num 1)).
14460 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 28 61 63 ;;; .. (ac
14470 74 2d 63 6f 72 65 20 28 2b 20 63 6f 72 65 2d 6e t-core (+ core-n
14480 75 6d 20 31 29 29 0a 3b 3b 3b 20 09 09 20 20 20 um 1)).;;; ..
14490 20 20 20 20 28 61 64 6a 2d 70 72 6f 63 2d 6c 6f (adj-proc-lo
144a0 61 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 ad (/ (car loads
144b0 29 20 61 63 74 2d 70 72 6f 63 29 29 0a 3b 3b 3b ) act-proc)).;;;
144c0 20 09 09 20 20 20 20 20 20 20 28 61 64 6a 2d 63 .. (adj-c
144d0 6f 72 65 2d 6c 6f 61 64 20 28 2f 20 28 63 61 72 ore-load (/ (car
144e0 20 6c 6f 61 64 73 29 20 61 63 74 2d 63 6f 72 65 loads) act-core
144f0 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 )).;;; ..
14500 28 72 65 73 75 6c 74 0a 3b 3b 3b 20 09 09 09 28 (result.;;; ...(
14510 61 70 70 65 6e 64 20 28 6c 69 73 74 20 28 63 6f append (list (co
14520 6e 73 20 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 ns 'adj-proc-loa
14530 64 20 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 29 d adj-proc-load)
14540 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 20 20 28 .;;; .... (
14550 63 6f 6e 73 20 27 61 64 6a 2d 63 6f 72 65 2d 6c cons 'adj-core-l
14560 6f 61 64 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 oad adj-core-loa
14570 64 29 29 0a 3b 3b 3b 20 09 09 09 09 28 6c 69 73 d)).;;; ....(lis
14580 74 20 28 63 6f 6e 73 20 27 31 6d 2d 6c 6f 61 64 t (cons '1m-load
14590 20 28 63 61 72 20 6c 6f 61 64 73 29 29 0a 3b 3b (car loads)).;;
145a0 3b 20 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e ; .... (con
145b0 73 20 27 35 6d 2d 6c 6f 61 64 20 28 63 61 64 72 s '5m-load (cadr
145c0 20 6c 6f 61 64 73 29 29 0a 3b 3b 3b 20 09 09 09 loads)).;;; ...
145d0 09 20 20 20 20 20 20 28 63 6f 6e 73 20 27 31 35 . (cons '15
145e0 6d 2d 6c 6f 61 64 20 28 63 61 64 64 72 20 6c 6f m-load (caddr lo
145f0 61 64 73 29 29 29 0a 3b 3b 3b 20 09 09 09 09 28 ads))).;;; ....(
14600 6c 69 73 74 20 28 63 6f 6e 73 20 27 70 72 6f 63 list (cons 'proc
14610 20 61 63 74 2d 70 72 6f 63 29 0a 3b 3b 3b 20 09 act-proc).;;; .
14620 09 09 09 20 20 20 20 20 20 28 63 6f 6e 73 20 27 ... (cons '
14630 63 6f 72 65 20 61 63 74 2d 63 6f 72 65 29 0a 3b core act-core).;
14640 3b 3b 20 09 09 09 09 20 20 20 20 20 20 28 63 6f ;; .... (co
14650 6e 73 20 27 70 68 79 73 20 61 63 74 2d 70 68 79 ns 'phys act-phy
14660 73 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 20 72 s))))).;;; .. r
14670 65 73 75 6c 74 29 0a 3b 3b 3b 20 09 09 28 72 65 esult).;;; ..(re
14680 67 65 78 2d 63 61 73 65 0a 3b 3b 3b 20 09 09 20 gex-case.;;; ..
14690 20 20 20 68 65 64 0a 3b 3b 3b 20 09 09 20 20 28 hed.;;; .. (
146a0 6c 6f 61 64 2d 72 78 20 20 28 20 78 20 6c 31 20 load-rx ( x l1
146b0 6c 35 20 6c 31 35 20 29 20 28 6c 6f 6f 70 20 28 l5 l15 ) (loop (
146c0 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
146d0 29 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 )(map string->nu
146e0 6d 62 65 72 20 28 6c 69 73 74 20 6c 31 20 6c 35 mber (list l1 l5
146f0 20 6c 31 35 29 29 20 70 72 6f 63 2d 6e 75 6d 20 l15)) proc-num
14700 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 phys-num core-nu
14710 6d 29 29 0a 3b 3b 3b 20 09 09 20 20 28 70 72 6f m)).;;; .. (pro
14720 63 2d 72 78 20 20 28 20 78 20 70 20 20 20 20 20 c-rx ( x p
14730 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 ) (loop (car
14740 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c tal)(cdr tal) l
14750 6f 61 64 73 20 20 20 20 20 20 20 20 20 20 20 28 oads (
14760 6d 61 78 2d 6e 75 6d 20 70 20 70 72 6f 63 2d 6e max-num p proc-n
14770 75 6d 29 20 70 68 79 73 2d 6e 75 6d 20 63 6f 72 um) phys-num cor
14780 65 2d 6e 75 6d 29 29 0a 3b 3b 3b 20 09 09 20 20 e-num)).;;; ..
14790 28 70 68 79 73 2d 72 78 20 20 28 20 78 20 70 20 (phys-rx ( x p
147a0 20 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 ) (loop
147b0 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
147c0 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 l) loads
147d0 20 20 20 70 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 proc-num (max
147e0 2d 6e 75 6d 20 70 20 70 68 79 73 2d 6e 75 6d 29 -num p phys-num)
147f0 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 3b 3b 3b 20 core-num)).;;;
14800 09 09 20 20 28 63 6f 72 65 2d 72 78 20 20 28 20 .. (core-rx (
14810 78 20 63 20 20 20 20 20 20 20 20 20 29 20 28 6c x c ) (l
14820 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
14830 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 r tal) loads
14840 20 20 20 20 20 20 20 70 72 6f 63 2d 6e 75 6d 20 proc-num
14850 70 68 79 73 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 phys-num (max-nu
14860 6d 20 63 20 63 6f 72 65 2d 6e 75 6d 29 29 29 0a m c core-num))).
14870 3b 3b 3b 20 09 09 20 20 28 65 6c 73 65 20 0a 3b ;;; .. (else .;
14880 3b 3b 20 09 09 20 20 20 28 62 65 67 69 6e 0a 3b ;; .. (begin.;
14890 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 28 70 72 ;; .. ;; (pr
148a0 69 6e 74 20 22 4e 4f 20 4d 41 54 43 48 3a 20 22 int "NO MATCH: "
148b0 20 68 65 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 hed).;;; ..
148c0 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
148d0 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 (cdr tal) loads
148e0 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 proc-num phys-nu
148f0 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 29 29 29 29 m core-num))))))
14900 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 )))).;;; .;;; (d
14910 65 66 69 6e 65 20 28 67 65 74 2d 68 6f 73 74 2d efine (get-host-
14920 73 74 61 74 73 20 61 63 66 67 29 0a 3b 3b 3b 20 stats acfg).;;;
14930 20 20 28 6c 65 74 20 28 28 73 74 61 74 73 2d 68 (let ((stats-h
14940 61 73 68 20 28 61 72 65 61 2d 73 74 61 74 73 20 ash (area-stats
14950 61 63 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 acfg))).;;;
14960 3b 3b 20 75 73 65 20 74 68 69 73 20 6f 70 70 6f ;; use this oppo
14970 72 74 75 6e 69 74 79 20 74 6f 20 72 65 6d 6f 76 rtunity to remov
14980 65 20 72 65 66 65 72 65 6e 63 65 73 20 74 6f 20 e references to
14990 64 62 66 69 6c 65 73 20 77 68 69 63 68 20 68 61 dbfiles which ha
149a0 76 65 20 6e 6f 74 20 62 65 65 6e 20 61 63 63 65 ve not been acce
149b0 73 73 65 64 20 69 6e 20 61 20 77 68 69 6c 65 0a ssed in a while.
149c0 3b 3b 3b 20 20 20 20 20 28 66 6f 72 2d 65 61 63 ;;; (for-eac
149d0 68 0a 3b 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 h.;;; (lamb
149e0 64 61 20 28 64 62 6e 61 6d 65 29 0a 3b 3b 3b 20 da (dbname).;;;
149f0 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 (let* ((s
14a00 74 61 74 73 20 20 20 20 20 20 20 28 68 61 73 68 tats (hash
14a10 2d 74 61 62 6c 65 2d 72 65 66 20 73 74 61 74 73 -table-ref stats
14a20 2d 68 61 73 68 20 64 62 6e 61 6d 65 29 29 0a 3b -hash dbname)).;
14a30 3b 3b 20 09 20 20 20 20 20 20 28 6c 61 73 74 2d ;; . (last-
14a40 61 63 63 65 73 73 20 28 73 74 61 74 2d 77 68 65 access (stat-whe
14a50 6e 20 73 74 61 74 73 29 29 29 0a 3b 3b 3b 20 09 n stats))).;;; .
14a60 20 28 69 66 20 28 61 6e 64 20 28 3e 20 6c 61 73 (if (and (> las
14a70 74 2d 61 63 63 65 73 73 20 30 29 20 20 20 20 20 t-access 0)
14a80 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14a90 20 20 20 20 20 20 20 20 3b 3b 20 69 66 20 7a 65 ;; if ze
14aa0 72 6f 20 74 68 65 6e 20 74 68 65 72 65 20 68 61 ro then there ha
14ab0 73 20 62 65 65 6e 20 6e 6f 20 61 63 63 65 73 73 s been no access
14ac0 0a 3b 3b 3b 20 09 09 20 20 28 3e 20 28 2d 20 28 .;;; .. (> (- (
14ad0 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
14ae0 20 6c 61 73 74 2d 61 63 63 65 73 73 29 20 31 30 last-access) 10
14af0 29 29 20 20 20 20 20 3b 3b 20 6e 6f 74 20 75 73 )) ;; not us
14b00 65 64 20 69 6e 20 74 65 6e 20 73 65 63 6f 6e 64 ed in ten second
14b10 73 0a 3b 3b 3b 20 09 20 20 20 20 20 28 62 65 67 s.;;; . (beg
14b20 69 6e 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 in.;;; . (
14b30 70 72 69 6e 74 20 22 52 65 6d 6f 76 69 6e 67 20 print "Removing
14b40 22 20 64 62 6e 61 6d 65 20 22 20 66 72 6f 6d 20 " dbname " from
14b50 73 74 61 74 73 20 6c 69 73 74 22 29 0a 3b 3b 3b stats list").;;;
14b60 20 09 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 . (hash-t
14b70 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 73 74 61 able-delete! sta
14b80 74 73 2d 68 61 73 68 20 64 62 6e 61 6d 65 29 20 ts-hash dbname)
14b90 3b 3b 20 72 65 6d 6f 76 65 20 66 72 6f 6d 20 73 ;; remove from s
14ba0 74 61 74 73 20 68 61 73 68 0a 3b 3b 3b 20 09 20 tats hash.;;; .
14bb0 20 20 20 20 20 20 28 73 74 61 74 2d 64 62 73 2d (stat-dbs-
14bc0 73 65 74 21 20 73 74 61 74 73 20 28 68 61 73 68 set! stats (hash
14bd0 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 -table-keys stat
14be0 73 29 29 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 s)))))).;;;
14bf0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
14c00 73 20 73 74 61 74 73 2d 68 61 73 68 29 29 0a 3b s stats-hash)).;
14c10 3b 3b 20 20 20 20 20 0a 3b 3b 3b 20 20 20 20 20 ;; .;;;
14c20 60 28 2c 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e `(,(hash-table->
14c30 61 6c 69 73 74 20 28 61 72 65 61 2d 64 62 73 20 alist (area-dbs
14c40 61 63 66 67 29 29 20 3b 3b 20 64 62 6e 61 6d 65 acfg)) ;; dbname
14c50 20 3d 3e 20 72 61 6e 64 6e 75 6d 0a 3b 3b 3b 20 => randnum.;;;
14c60 20 20 20 20 20 20 2c 28 6d 61 70 20 28 6c 61 6d ,(map (lam
14c70 62 64 61 20 28 64 62 6e 61 6d 65 29 20 20 3b 3b bda (dbname) ;;
14c80 20 64 62 6e 61 6d 65 20 69 73 20 74 68 65 20 64 dbname is the d
14c90 62 20 6e 61 6d 65 0a 3b 3b 3b 20 09 20 20 20 20 b name.;;; .
14ca0 20 20 28 63 6f 6e 73 20 64 62 6e 61 6d 65 20 28 (cons dbname (
14cb0 73 74 61 74 2d 77 68 65 6e 20 28 68 61 73 68 2d stat-when (hash-
14cc0 74 61 62 6c 65 2d 72 65 66 20 73 74 61 74 73 2d table-ref stats-
14cd0 68 61 73 68 20 64 62 6e 61 6d 65 29 29 29 29 0a hash dbname)))).
14ce0 3b 3b 3b 20 09 20 20 20 20 28 68 61 73 68 2d 74 ;;; . (hash-t
14cf0 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 73 2d able-keys stats-
14d00 68 61 73 68 29 29 0a 3b 3b 3b 20 20 20 20 20 20 hash)).;;;
14d10 20 28 63 70 75 6c 6f 61 64 20 2e 20 2c 28 67 65 (cpuload . ,(ge
14d20 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 t-normalized-cpu
14d30 2d 6c 6f 61 64 29 29 29 29 29 0a 3b 3b 3b 20 20 -load))))).;;;
14d40 20 20 20 23 3b 28 73 74 61 74 73 20 20 20 2e 20 #;(stats .
14d50 2c 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b ,(map (lambda (k
14d60 29 20 3b 3b 20 63 72 65 61 74 65 20 61 6e 20 61 ) ;; create an a
14d70 6c 69 73 74 20 66 72 6f 6d 20 74 68 65 20 73 74 list from the st
14d80 61 74 73 20 64 61 74 61 0a 3b 3b 3b 20 09 09 20 ats data.;;; ..
14d90 20 20 20 20 20 20 28 63 6f 6e 73 20 6b 20 28 73 (cons k (s
14da0 74 61 74 2d 3e 61 6c 69 73 74 20 28 68 61 73 68 tat->alist (hash
14db0 2d 74 61 62 6c 65 2d 72 65 66 20 28 61 72 65 61 -table-ref (area
14dc0 2d 73 74 61 74 73 20 61 63 66 67 29 20 6b 29 29 -stats acfg) k))
14dd0 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 68 )).;;; .. (h
14de0 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 28 ash-table-keys (
14df0 61 72 65 61 2d 73 74 61 74 73 20 61 63 66 67 29 area-stats acfg)
14e00 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 23 3b 28 ))).;;; .;;; #;(
14e10 74 72 61 63 65 0a 3b 3b 3b 20 20 3b 3b 20 61 73 trace.;;; ;; as
14e20 73 76 0a 3b 3b 3b 20 20 3b 3b 20 63 64 72 0a 3b sv.;;; ;; cdr.;
14e30 3b 3b 20 20 3b 3b 20 63 61 61 72 0a 3b 3b 3b 20 ;; ;; caar.;;;
14e40 20 3b 3b 20 3b 3b 20 63 64 72 0a 3b 3b 3b 20 20 ;; ;; cdr.;;;
14e50 3b 3b 20 63 61 6c 6c 0a 3b 3b 3b 20 20 3b 3b 20 ;; call.;;; ;;
14e60 66 69 6e 61 6c 69 7a 65 2d 61 6c 6c 2d 64 62 2d finalize-all-db-
14e70 68 61 6e 64 6c 65 73 0a 3b 3b 3b 20 20 3b 3b 20 handles.;;; ;;
14e80 67 65 74 2d 61 6c 6c 2d 73 65 72 76 65 72 2d 70 get-all-server-p
14e90 6b 74 73 0a 3b 3b 3b 20 20 3b 3b 20 67 65 74 2d kts.;;; ;; get-
14ea0 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c normalized-cpu-l
14eb0 6f 61 64 0a 3b 3b 3b 20 20 3b 3b 20 67 65 74 2d oad.;;; ;; get-
14ec0 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c normalized-cpu-l
14ed0 6f 61 64 2d 72 61 77 0a 3b 3b 3b 20 20 3b 3b 20 oad-raw.;;; ;;
14ee0 6c 61 75 6e 63 68 0a 3b 3b 3b 20 20 3b 3b 20 6e launch.;;; ;; n
14ef0 6d 73 67 2d 73 65 6e 64 0a 3b 3b 3b 20 20 3b 3b msg-send.;;; ;;
14f00 20 70 72 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 process-db-quer
14f10 69 65 73 0a 3b 3b 3b 20 20 3b 3b 20 72 65 63 65 ies.;;; ;; rece
14f20 69 76 65 2d 6d 65 73 73 61 67 65 0a 3b 3b 3b 20 ive-message.;;;
14f30 20 3b 3b 20 73 74 64 2d 70 65 65 72 2d 68 61 6e ;; std-peer-han
14f40 64 6c 65 72 0a 3b 3b 3b 20 20 3b 3b 20 75 70 64 dler.;;; ;; upd
14f50 61 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 ate-known-server
14f60 73 0a 3b 3b 3b 20 20 3b 3b 20 77 6f 72 6b 2d 71 s.;;; ;; work-q
14f70 75 65 75 65 2d 70 72 6f 63 65 73 73 6f 72 0a 3b ueue-processor.;
14f80 3b 3b 20 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b ;; ).;;; .;;; ;
14f90 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
14fa0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14fb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14fc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14fd0 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 6e =======.;;; ;; n
14fe0 65 74 75 74 69 6c 0a 3b 3b 3b 20 3b 3b 20 20 20 etutil.;;; ;;
14ff0 6d 6f 76 65 20 74 68 69 73 20 62 61 63 6b 20 74 move this back t
15000 6f 20 75 6c 65 78 2d 6e 65 74 75 74 69 6c 2e 73 o ulex-netutil.s
15010 63 6d 20 73 6f 6d 65 64 61 79 3f 0a 3b 3b 3b 20 cm someday?.;;;
15020 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
15030 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15040 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15050 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15060 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b ========.;;; .;;
15070 3b 20 3b 3b 20 23 69 6e 63 6c 75 64 65 20 3c 73 ; ;; #include <s
15080 74 64 69 6f 2e 68 3e 0a 3b 3b 3b 20 3b 3b 20 23 tdio.h>.;;; ;; #
15090 69 6e 63 6c 75 64 65 20 3c 6e 65 74 69 6e 65 74 include <netinet
150a0 2f 69 6e 2e 68 3e 0a 3b 3b 3b 20 3b 3b 20 23 69 /in.h>.;;; ;; #i
150b0 6e 63 6c 75 64 65 20 3c 73 74 72 69 6e 67 2e 68 nclude <string.h
150c0 3e 0a 3b 3b 3b 20 3b 3b 20 23 69 6e 63 6c 75 64 >.;;; ;; #includ
150d0 65 20 3c 61 72 70 61 2f 69 6e 65 74 2e 68 3e 0a e <arpa/inet.h>.
150e0 3b 3b 3b 20 0a 3b 3b 3b 20 28 66 6f 72 65 69 67 ;;; .;;; (foreig
150f0 6e 2d 64 65 63 6c 61 72 65 20 22 23 69 6e 63 6c n-declare "#incl
15100 75 64 65 20 5c 22 73 79 73 2f 74 79 70 65 73 2e ude \"sys/types.
15110 68 5c 22 22 29 0a 3b 3b 3b 20 28 66 6f 72 65 69 h\"").;;; (forei
15120 67 6e 2d 64 65 63 6c 61 72 65 20 22 23 69 6e 63 gn-declare "#inc
15130 6c 75 64 65 20 5c 22 73 79 73 2f 73 6f 63 6b 65 lude \"sys/socke
15140 74 2e 68 5c 22 22 29 0a 3b 3b 3b 20 28 66 6f 72 t.h\"").;;; (for
15150 65 69 67 6e 2d 64 65 63 6c 61 72 65 20 22 23 69 eign-declare "#i
15160 6e 63 6c 75 64 65 20 5c 22 69 66 61 64 64 72 73 nclude \"ifaddrs
15170 2e 68 5c 22 22 29 0a 3b 3b 3b 20 28 66 6f 72 65 .h\"").;;; (fore
15180 69 67 6e 2d 64 65 63 6c 61 72 65 20 22 23 69 6e ign-declare "#in
15190 63 6c 75 64 65 20 5c 22 61 72 70 61 2f 69 6e 65 clude \"arpa/ine
151a0 74 2e 68 5c 22 22 29 0a 3b 3b 3b 20 0a 3b 3b 3b t.h\"").;;; .;;;
151b0 20 3b 3b 20 67 65 74 20 49 50 20 61 64 64 72 65 ;; get IP addre
151c0 73 73 65 73 20 66 72 6f 6d 20 41 4c 4c 20 69 6e sses from ALL in
151d0 74 65 72 66 61 63 65 73 0a 3b 3b 3b 20 28 64 65 terfaces.;;; (de
151e0 66 69 6e 65 20 67 65 74 2d 61 6c 6c 2d 69 70 73 fine get-all-ips
151f0 0a 3b 3b 3b 20 20 20 28 66 6f 72 65 69 67 6e 2d .;;; (foreign-
15200 73 61 66 65 2d 6c 61 6d 62 64 61 2a 20 73 63 68 safe-lambda* sch
15210 65 6d 65 2d 6f 62 6a 65 63 74 20 28 29 0a 3b 3b eme-object ().;;
15220 3b 20 20 20 20 20 22 0a 3b 3b 3b 20 0a 3b 3b 3b ; ".;;; .;;;
15230 20 2f 2f 20 66 72 6f 6d 20 68 74 74 70 73 3a 2f // from https:/
15240 2f 73 74 61 63 6b 6f 76 65 72 66 6c 6f 77 2e 63 /stackoverflow.c
15250 6f 6d 2f 71 75 65 73 74 69 6f 6e 73 2f 31 37 39 om/questions/179
15260 30 39 34 30 31 2f 6c 69 6e 75 78 2d 63 2d 67 65 09401/linux-c-ge
15270 74 2d 64 65 66 61 75 6c 74 2d 69 6e 74 65 72 66 t-default-interf
15280 61 63 65 73 2d 69 70 2d 61 64 64 72 65 73 73 20 aces-ip-address
15290 3a 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 :.;;; .;;; .;;;
152a0 20 20 20 20 43 5f 77 6f 72 64 20 6c 73 74 20 3d C_word lst =
152b0 20 43 5f 53 43 48 45 4d 45 5f 45 4e 44 5f 4f 46 C_SCHEME_END_OF
152c0 5f 4c 49 53 54 2c 20 6c 65 6e 2c 20 73 74 72 2c _LIST, len, str,
152d0 20 2a 61 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 73 *a;.;;; // s
152e0 74 72 75 63 74 20 69 66 61 64 64 72 73 20 2a 69 truct ifaddrs *i
152f0 66 61 2c 20 2a 69 3b 0a 3b 3b 3b 20 2f 2f 20 20 fa, *i;.;;; //
15300 20 20 73 74 72 75 63 74 20 73 6f 63 6b 61 64 64 struct sockadd
15310 72 20 2a 73 61 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 r *sa;.;;; .;;;
15320 20 20 20 20 73 74 72 75 63 74 20 69 66 61 64 64 struct ifadd
15330 72 73 20 2a 20 69 66 41 64 64 72 53 74 72 75 63 rs * ifAddrStruc
15340 74 20 3d 20 4e 55 4c 4c 3b 0a 3b 3b 3b 20 20 20 t = NULL;.;;;
15350 20 20 73 74 72 75 63 74 20 69 66 61 64 64 72 73 struct ifaddrs
15360 20 2a 20 69 66 61 20 3d 20 4e 55 4c 4c 3b 0a 3b * ifa = NULL;.;
15370 3b 3b 20 20 20 20 20 76 6f 69 64 20 2a 20 74 6d ;; void * tm
15380 70 41 64 64 72 50 74 72 20 3d 20 4e 55 4c 4c 3b pAddrPtr = NULL;
15390 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 69 66 .;;; .;;; if
153a0 20 28 20 67 65 74 69 66 61 64 64 72 73 28 26 69 ( getifaddrs(&i
153b0 66 41 64 64 72 53 74 72 75 63 74 29 20 21 3d 20 fAddrStruct) !=
153c0 30 29 0a 3b 3b 3b 20 20 20 20 20 20 20 43 5f 72 0).;;; C_r
153d0 65 74 75 72 6e 28 43 5f 53 43 48 45 4d 45 5f 46 eturn(C_SCHEME_F
153e0 41 4c 53 45 29 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 ALSE);.;;; .;;;
153f0 2f 2f 20 20 20 20 66 6f 72 20 28 69 20 3d 20 69 // for (i = i
15400 66 61 3b 20 69 20 21 3d 20 4e 55 4c 4c 3b 20 69 fa; i != NULL; i
15410 20 3d 20 69 2d 3e 69 66 61 5f 6e 65 78 74 29 20 = i->ifa_next)
15420 7b 0a 3b 3b 3b 20 20 20 20 20 66 6f 72 20 28 69 {.;;; for (i
15430 66 61 20 3d 20 69 66 41 64 64 72 53 74 72 75 63 fa = ifAddrStruc
15440 74 3b 20 69 66 61 20 21 3d 20 4e 55 4c 4c 3b 20 t; ifa != NULL;
15450 69 66 61 20 3d 20 69 66 61 2d 3e 69 66 61 5f 6e ifa = ifa->ifa_n
15460 65 78 74 29 20 7b 0a 3b 3b 3b 20 20 20 20 20 20 ext) {.;;;
15470 20 20 20 69 66 20 28 69 66 61 2d 3e 69 66 61 5f if (ifa->ifa_
15480 61 64 64 72 2d 3e 73 61 5f 66 61 6d 69 6c 79 3d addr->sa_family=
15490 3d 41 46 5f 49 4e 45 54 29 20 7b 20 2f 2f 20 43 =AF_INET) { // C
154a0 68 65 63 6b 20 69 74 20 69 73 0a 3b 3b 3b 20 20 heck it is.;;;
154b0 20 20 20 20 20 20 20 20 20 20 20 2f 2f 20 61 20 // a
154c0 76 61 6c 69 64 20 49 50 76 34 20 61 64 64 72 65 valid IPv4 addre
154d0 73 73 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 ss.;;;
154e0 20 20 20 74 6d 70 41 64 64 72 50 74 72 20 3d 20 tmpAddrPtr =
154f0 26 28 28 73 74 72 75 63 74 20 73 6f 63 6b 61 64 &((struct sockad
15500 64 72 5f 69 6e 20 2a 29 69 66 61 2d 3e 69 66 61 dr_in *)ifa->ifa
15510 5f 61 64 64 72 29 2d 3e 73 69 6e 5f 61 64 64 72 _addr)->sin_addr
15520 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;.;;;
15530 20 20 63 68 61 72 20 61 64 64 72 65 73 73 42 75 char addressBu
15540 66 66 65 72 5b 49 4e 45 54 5f 41 44 44 52 53 54 ffer[INET_ADDRST
15550 52 4c 45 4e 5d 3b 0a 3b 3b 3b 20 20 20 20 20 20 RLEN];.;;;
15560 20 20 20 20 20 20 20 69 6e 65 74 5f 6e 74 6f 70 inet_ntop
15570 28 41 46 5f 49 4e 45 54 2c 20 74 6d 70 41 64 64 (AF_INET, tmpAdd
15580 72 50 74 72 2c 20 61 64 64 72 65 73 73 42 75 66 rPtr, addressBuf
15590 66 65 72 2c 20 49 4e 45 54 5f 41 44 44 52 53 54 fer, INET_ADDRST
155a0 52 4c 45 4e 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 RLEN);.;;; //
155b0 20 20 20 20 20 20 20 20 20 70 72 69 6e 74 66 28 printf(
155c0 5c 22 25 73 20 49 50 20 41 64 64 72 65 73 73 20 \"%s IP Address
155d0 25 73 5c 5c 6e 5c 22 2c 20 69 66 61 2d 3e 69 66 %s\\n\", ifa->if
155e0 61 5f 6e 61 6d 65 2c 20 61 64 64 72 65 73 73 42 a_name, addressB
155f0 75 66 66 65 72 29 3b 0a 3b 3b 3b 20 20 20 20 20 uffer);.;;;
15600 20 20 20 20 20 20 20 20 6c 65 6e 20 3d 20 73 74 len = st
15610 72 6c 65 6e 28 61 64 64 72 65 73 73 42 75 66 66 rlen(addressBuff
15620 65 72 29 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 er);.;;;
15630 20 20 20 20 20 61 20 3d 20 43 5f 61 6c 6c 6f 63 a = C_alloc
15640 28 43 5f 53 49 5a 45 4f 46 5f 50 41 49 52 20 2b (C_SIZEOF_PAIR +
15650 20 43 5f 53 49 5a 45 4f 46 5f 53 54 52 49 4e 47 C_SIZEOF_STRING
15660 28 6c 65 6e 29 29 3b 0a 3b 3b 3b 20 20 20 20 20 (len));.;;;
15670 20 20 20 20 20 20 20 20 73 74 72 20 3d 20 43 5f str = C_
15680 73 74 72 69 6e 67 28 26 61 2c 20 6c 65 6e 2c 20 string(&a, len,
15690 61 64 64 72 65 73 73 42 75 66 66 65 72 29 3b 0a addressBuffer);.
156a0 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;;
156b0 6c 73 74 20 3d 20 43 5f 61 5f 70 61 69 72 28 26 lst = C_a_pair(&
156c0 61 2c 20 73 74 72 2c 20 6c 73 74 29 3b 0a 3b 3b a, str, lst);.;;
156d0 3b 20 20 20 20 20 20 20 20 20 7d 20 0a 3b 3b 3b ; } .;;;
156e0 20 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 20 .;;; //
156f0 65 6c 73 65 20 69 66 20 28 69 66 61 2d 3e 69 66 else if (ifa->if
15700 61 5f 61 64 64 72 2d 3e 73 61 5f 66 61 6d 69 6c a_addr->sa_famil
15710 79 3d 3d 41 46 5f 49 4e 45 54 36 29 20 7b 20 2f y==AF_INET6) { /
15720 2f 20 43 68 65 63 6b 20 69 74 20 69 73 0a 3b 3b / Check it is.;;
15730 3b 20 2f 2f 20 20 20 20 20 20 20 20 20 20 20 20 ; //
15740 2f 2f 20 61 20 76 61 6c 69 64 20 49 50 76 36 20 // a valid IPv6
15750 61 64 64 72 65 73 73 0a 3b 3b 3b 20 2f 2f 20 20 address.;;; //
15760 20 20 20 20 20 20 20 20 20 20 74 6d 70 41 64 64 tmpAdd
15770 72 50 74 72 20 3d 20 26 28 28 73 74 72 75 63 74 rPtr = &((struct
15780 20 73 6f 63 6b 61 64 64 72 5f 69 6e 36 20 2a 29 sockaddr_in6 *)
15790 69 66 61 2d 3e 69 66 61 5f 61 64 64 72 29 2d 3e ifa->ifa_addr)->
157a0 73 69 6e 36 5f 61 64 64 72 3b 0a 3b 3b 3b 20 2f sin6_addr;.;;; /
157b0 2f 20 20 20 20 20 20 20 20 20 20 20 20 63 68 61 / cha
157c0 72 20 61 64 64 72 65 73 73 42 75 66 66 65 72 5b r addressBuffer[
157d0 49 4e 45 54 36 5f 41 44 44 52 53 54 52 4c 45 4e INET6_ADDRSTRLEN
157e0 5d 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 ];.;;; //
157f0 20 20 20 20 20 69 6e 65 74 5f 6e 74 6f 70 28 41 inet_ntop(A
15800 46 5f 49 4e 45 54 36 2c 20 74 6d 70 41 64 64 72 F_INET6, tmpAddr
15810 50 74 72 2c 20 61 64 64 72 65 73 73 42 75 66 66 Ptr, addressBuff
15820 65 72 2c 20 49 4e 45 54 36 5f 41 44 44 52 53 54 er, INET6_ADDRST
15830 52 4c 45 4e 29 3b 0a 3b 3b 3b 20 2f 2f 2f 2f 20 RLEN);.;;; ////
15840 20 20 20 20 20 20 20 20 20 20 20 70 72 69 6e 74 print
15850 66 28 5c 22 25 73 20 49 50 20 41 64 64 72 65 73 f(\"%s IP Addres
15860 73 20 25 73 5c 5c 6e 5c 22 2c 20 69 66 61 2d 3e s %s\\n\", ifa->
15870 69 66 61 5f 6e 61 6d 65 2c 20 61 64 64 72 65 73 ifa_name, addres
15880 73 42 75 66 66 65 72 29 3b 0a 3b 3b 3b 20 2f 2f sBuffer);.;;; //
15890 20 20 20 20 20 20 20 20 20 20 20 20 6c 65 6e 20 len
158a0 3d 20 73 74 72 6c 65 6e 28 61 64 64 72 65 73 73 = strlen(address
158b0 42 75 66 66 65 72 29 3b 0a 3b 3b 3b 20 2f 2f 20 Buffer);.;;; //
158c0 20 20 20 20 20 20 20 20 20 20 20 61 20 3d 20 43 a = C
158d0 5f 61 6c 6c 6f 63 28 43 5f 53 49 5a 45 4f 46 5f _alloc(C_SIZEOF_
158e0 50 41 49 52 20 2b 20 43 5f 53 49 5a 45 4f 46 5f PAIR + C_SIZEOF_
158f0 53 54 52 49 4e 47 28 6c 65 6e 29 29 3b 0a 3b 3b STRING(len));.;;
15900 3b 20 2f 2f 20 20 20 20 20 20 20 20 20 20 20 20 ; //
15910 73 74 72 20 3d 20 43 5f 73 74 72 69 6e 67 28 26 str = C_string(&
15920 61 2c 20 6c 65 6e 2c 20 61 64 64 72 65 73 73 42 a, len, addressB
15930 75 66 66 65 72 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 uffer);.;;; //
15940 20 20 20 20 20 20 20 20 20 20 6c 73 74 20 3d 20 lst =
15950 43 5f 61 5f 70 61 69 72 28 26 61 2c 20 73 74 72 C_a_pair(&a, str
15960 2c 20 6c 73 74 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 , lst);.;;; //
15970 20 20 20 20 20 7d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 }.;;; .;;;
15980 2f 2f 20 20 20 20 20 20 20 65 6c 73 65 20 7b 0a // else {.
15990 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 20 20 70 ;;; // p
159a0 72 69 6e 74 66 28 5c 22 20 6e 6f 74 20 61 6e 20 rintf(\" not an
159b0 49 50 76 34 20 61 64 64 72 65 73 73 5c 5c 6e 5c IPv4 address\\n\
159c0 22 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 ");.;;; //
159d0 20 7d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 }.;;; .;;;
159e0 7d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 66 }.;;; .;;; f
159f0 72 65 65 69 66 61 64 64 72 73 28 69 66 61 29 3b reeifaddrs(ifa);
15a00 0a 3b 3b 3b 20 20 20 20 20 43 5f 72 65 74 75 72 .;;; C_retur
15a10 6e 28 6c 73 74 29 3b 0a 3b 3b 3b 20 0a 3b 3b 3b n(lst);.;;; .;;;
15a20 20 22 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b ")).;;; .;;; ;;
15a30 20 43 68 61 6e 67 65 20 74 68 69 73 20 74 6f 20 Change this to
15a40 62 69 61 73 20 66 6f 72 20 61 64 64 72 65 73 73 bias for address
15a50 65 73 20 77 69 74 68 20 61 20 72 65 61 73 6f 6e es with a reason
15a60 61 62 6c 65 20 62 72 6f 61 64 63 61 73 74 20 76 able broadcast v
15a70 61 6c 75 65 3f 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b alue?.;;; ;;.;;;
15a80 20 28 64 65 66 69 6e 65 20 28 69 70 2d 70 72 65 (define (ip-pre
15a90 66 2d 6c 65 73 73 3f 20 61 20 62 29 0a 3b 3b 3b f-less? a b).;;;
15aa0 20 20 20 28 6c 65 74 2a 20 28 28 72 61 74 65 20 (let* ((rate
15ab0 28 6c 61 6d 62 64 61 20 28 69 70 73 74 72 29 0a (lambda (ipstr).
15ac0 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;;
15ad0 20 20 20 20 20 28 72 65 67 65 78 2d 63 61 73 65 (regex-case
15ae0 20 69 70 73 74 72 0a 3b 3b 3b 20 20 20 20 20 20 ipstr.;;;
15af0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15b00 20 20 20 20 20 20 20 20 28 20 22 5e 31 32 37 5c ( "^127\
15b10 5c 2e 22 20 5f 20 30 20 29 0a 3b 3b 3b 20 20 20 \." _ 0 ).;;;
15b20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15b30 20 20 20 20 20 20 20 20 20 20 20 28 20 22 5e 28 ( "^(
15b40 31 30 5c 5c 2e 30 7c 31 39 32 5c 5c 2e 31 36 38 10\\.0|192\\.168
15b50 5c 5c 2e 29 5c 5c 2e 2e 2a 22 20 5f 20 31 20 29 \\.)\\..*" _ 1 )
15b60 0a 3b 3b 3b 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 28 20 65 6c 73 65 20 32 20 29 20 29 29 29 ( else 2 ) )))
15b90 29 0a 3b 3b 3b 20 20 20 20 20 28 3c 20 28 72 61 ).;;; (< (ra
15ba0 74 65 20 61 29 20 28 72 61 74 65 20 62 29 29 29 te a) (rate b)))
15bb0 29 0a 3b 3b 3b 20 20 20 0a 3b 3b 3b 20 0a 3b 3b ).;;; .;;; .;;
15bc0 3b 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6d ; (define (get-m
15bd0 79 2d 62 65 73 74 2d 61 64 64 72 65 73 73 29 0a y-best-address).
15be0 3b 3b 3b 20 20 20 28 6c 65 74 20 28 28 61 6c 6c ;;; (let ((all
15bf0 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 20 28 67 -my-addresses (g
15c00 65 74 2d 61 6c 6c 2d 69 70 73 29 29 0a 3b 3b 3b et-all-ips)).;;;
15c10 20 20 20 20 20 20 20 20 20 3b 3b 28 61 6c 6c 2d ;;(all-
15c20 6d 79 2d 61 64 64 72 65 73 73 65 73 2d 6f 6c 64 my-addresses-old
15c30 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 (vector->list (
15c40 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 hostinfo-address
15c50 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f es (hostname->ho
15c60 73 74 69 6e 66 6f 20 28 67 65 74 2d 68 6f 73 74 stinfo (get-host
15c70 2d 6e 61 6d 65 29 29 29 29 29 0a 3b 3b 3b 20 20 -name))))).;;;
15c80 20 20 20 20 20 20 20 29 0a 3b 3b 3b 20 20 20 20 ).;;;
15c90 20 28 63 6f 6e 64 0a 3b 3b 3b 20 20 20 20 20 20 (cond.;;;
15ca0 28 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 ((null? all-my-a
15cb0 64 64 72 65 73 73 65 73 29 0a 3b 3b 3b 20 20 20 ddresses).;;;
15cc0 20 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 (get-host-na
15cd0 6d 65 29 29 20 20 20 20 20 20 20 20 20 20 20 20 me))
15ce0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15cf0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
15d00 20 6e 6f 20 69 6e 74 65 72 66 61 63 65 73 3f 0a no interfaces?.
15d10 3b 3b 3b 20 20 20 20 20 20 28 28 65 71 3f 20 28 ;;; ((eq? (
15d20 6c 65 6e 67 74 68 20 61 6c 6c 2d 6d 79 2d 61 64 length all-my-ad
15d30 64 72 65 73 73 65 73 29 20 31 29 0a 3b 3b 3b 20 dresses) 1).;;;
15d40 20 20 20 20 20 20 28 63 61 72 20 61 6c 6c 2d 6d (car all-m
15d50 79 2d 61 64 64 72 65 73 73 65 73 29 29 20 20 20 y-addresses))
15d60 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15d70 20 20 20 3b 3b 20 6f 6e 6c 79 20 6f 6e 65 20 74 ;; only one t
15d80 6f 20 63 68 6f 6f 73 65 20 66 72 6f 6d 2c 20 6a o choose from, j
15d90 75 73 74 20 67 6f 20 77 69 74 68 20 69 74 0a 3b ust go with it.;
15da0 3b 3b 20 20 20 20 20 20 0a 3b 3b 3b 20 20 20 20 ;; .;;;
15db0 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 20 20 20 20 (else.;;;
15dc0 20 20 28 63 61 72 20 28 73 6f 72 74 20 61 6c 6c (car (sort all
15dd0 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 20 69 70 -my-addresses ip
15de0 2d 70 72 65 66 2d 6c 65 73 73 3f 29 29 29 0a 3b -pref-less?))).;
15df0 3b 3b 20 20 20 20 20 20 3b 3b 20 28 65 6c 73 65 ;; ;; (else
15e00 20 0a 3b 3b 3b 20 20 20 20 20 20 3b 3b 20 20 28 .;;; ;; (
15e10 69 70 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 20 ip->string (car
15e20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
15e30 28 78 29 20 20 20 20 20 20 20 20 20 20 20 20 20 (x)
15e40 20 20 20 20 20 20 20 20 20 3b 3b 20 74 61 6b 65 ;; take
15e50 20 61 6e 79 20 62 75 74 20 31 32 37 2e 0a 3b 3b any but 127..;;
15e60 3b 20 20 20 20 20 20 3b 3b 20 20 20 20 09 09 09 ; ;; ...
15e70 20 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 (not (eq? (u8ve
15e80 63 74 6f 72 2d 72 65 66 20 78 20 30 29 20 31 32 ctor-ref x 0) 12
15e90 37 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 3b 3b 7))).;;; ;;
15ea0 20 20 20 20 09 09 20 20 20 20 20 20 20 61 6c 6c .. all
15eb0 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 29 29 -my-addresses)))
15ec0 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 20 ).;;; .;;;
15ed0 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 ))).;;; .;;; (de
15ee0 66 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 69 70 fine (get-all-ip
15ef0 73 2d 73 6f 72 74 65 64 29 0a 3b 3b 3b 20 20 20 s-sorted).;;;
15f00 28 73 6f 72 74 20 28 67 65 74 2d 61 6c 6c 2d 69 (sort (get-all-i
15f10 70 73 29 20 69 70 2d 70 72 65 66 2d 6c 65 73 73 ps) ip-pref-less
15f20 3f 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 0a ?)).;;; .;;; ..