0000: 3b 3b 3b 20 75 6c 65 78 3a 20 44 69 73 74 72 69 ;;; ulex: Distri
0010: 62 75 74 65 64 20 73 71 6c 69 74 65 33 20 64 62 buted sqlite3 db
0020: 0a 3b 3b 3b 0a 3b 3b 20 43 6f 70 79 72 69 67 68 .;;;.;; Copyrigh
0030: 74 20 28 43 29 20 32 30 31 38 20 4d 61 74 74 20 t (C) 2018 Matt
0040: 57 65 6c 6c 61 6e 64 0a 3b 3b 20 52 65 64 69 73 Welland.;; Redis
0050: 74 72 69 62 75 74 69 6f 6e 20 61 6e 64 20 75 73 tribution and us
0060: 65 20 69 6e 20 73 6f 75 72 63 65 20 61 6e 64 20 e in source and
0070: 62 69 6e 61 72 79 20 66 6f 72 6d 73 2c 20 77 69 binary forms, wi
0080: 74 68 20 6f 72 20 77 69 74 68 6f 75 74 0a 3b 3b th or without.;;
0090: 20 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2c 20 69 modification, i
00a0: 73 20 70 65 72 6d 69 74 74 65 64 2e 0a 3b 3b 0a s permitted..;;.
00b0: 3b 3b 20 54 48 49 53 20 53 4f 46 54 57 41 52 45 ;; THIS SOFTWARE
00c0: 20 49 53 20 50 52 4f 56 49 44 45 44 20 42 59 20 IS PROVIDED BY
00d0: 54 48 45 20 41 55 54 48 4f 52 20 60 60 41 53 20 THE AUTHOR ``AS
00e0: 49 53 27 27 20 41 4e 44 20 41 4e 59 20 45 58 50 IS'' AND ANY EXP
00f0: 52 45 53 53 0a 3b 3b 20 4f 52 20 49 4d 50 4c 49 RESS.;; OR IMPLI
0100: 45 44 20 57 41 52 52 41 4e 54 49 45 53 2c 20 49 ED WARRANTIES, I
0110: 4e 43 4c 55 44 49 4e 47 2c 20 42 55 54 20 4e 4f NCLUDING, BUT NO
0120: 54 20 4c 49 4d 49 54 45 44 20 54 4f 2c 20 54 48 T LIMITED TO, TH
0130: 45 20 49 4d 50 4c 49 45 44 0a 3b 3b 20 57 41 52 E IMPLIED.;; WAR
0140: 52 41 4e 54 49 45 53 20 4f 46 20 4d 45 52 43 48 RANTIES OF MERCH
0150: 41 4e 54 41 42 49 4c 49 54 59 20 41 4e 44 20 46 ANTABILITY AND F
0160: 49 54 4e 45 53 53 20 46 4f 52 20 41 20 50 41 52 ITNESS FOR A PAR
0170: 54 49 43 55 4c 41 52 20 50 55 52 50 4f 53 45 0a TICULAR PURPOSE.
0180: 3b 3b 20 41 52 45 20 44 49 53 43 4c 41 49 4d 45 ;; ARE DISCLAIME
0190: 44 2e 20 20 49 4e 20 4e 4f 20 45 56 45 4e 54 20 D. IN NO EVENT
01a0: 53 48 41 4c 4c 20 54 48 45 20 41 55 54 48 4f 52 SHALL THE AUTHOR
01b0: 20 4f 52 20 43 4f 4e 54 52 49 42 55 54 4f 52 53 OR CONTRIBUTORS
01c0: 20 42 45 0a 3b 3b 20 4c 49 41 42 4c 45 20 46 4f BE.;; LIABLE FO
01d0: 52 20 41 4e 59 20 44 49 52 45 43 54 2c 20 49 4e R ANY DIRECT, IN
01e0: 44 49 52 45 43 54 2c 20 49 4e 43 49 44 45 4e 54 DIRECT, INCIDENT
01f0: 41 4c 2c 20 53 50 45 43 49 41 4c 2c 20 45 58 45 AL, SPECIAL, EXE
0200: 4d 50 4c 41 52 59 2c 20 4f 52 0a 3b 3b 20 43 4f MPLARY, OR.;; CO
0210: 4e 53 45 51 55 45 4e 54 49 41 4c 20 44 41 4d 41 NSEQUENTIAL DAMA
0220: 47 45 53 20 28 49 4e 43 4c 55 44 49 4e 47 2c 20 GES (INCLUDING,
0230: 42 55 54 20 4e 4f 54 20 4c 49 4d 49 54 45 44 20 BUT NOT LIMITED
0240: 54 4f 2c 20 50 52 4f 43 55 52 45 4d 45 4e 54 0a TO, PROCUREMENT.
0250: 3b 3b 20 4f 46 20 53 55 42 53 54 49 54 55 54 45 ;; OF SUBSTITUTE
0260: 20 47 4f 4f 44 53 20 4f 52 20 53 45 52 56 49 43 GOODS OR SERVIC
0270: 45 53 3b 20 4c 4f 53 53 20 4f 46 20 55 53 45 2c ES; LOSS OF USE,
0280: 20 44 41 54 41 2c 20 4f 52 20 50 52 4f 46 49 54 DATA, OR PROFIT
0290: 53 3b 20 4f 52 0a 3b 3b 20 42 55 53 49 4e 45 53 S; OR.;; BUSINES
02a0: 53 20 49 4e 54 45 52 52 55 50 54 49 4f 4e 29 20 S INTERRUPTION)
02b0: 48 4f 57 45 56 45 52 20 43 41 55 53 45 44 20 41 HOWEVER CAUSED A
02c0: 4e 44 20 4f 4e 20 41 4e 59 20 54 48 45 4f 52 59 ND ON ANY THEORY
02d0: 20 4f 46 0a 3b 3b 20 4c 49 41 42 49 4c 49 54 59 OF.;; LIABILITY
02e0: 2c 20 57 48 45 54 48 45 52 20 49 4e 20 43 4f 4e , WHETHER IN CON
02f0: 54 52 41 43 54 2c 20 53 54 52 49 43 54 20 4c 49 TRACT, STRICT LI
0300: 41 42 49 4c 49 54 59 2c 20 4f 52 20 54 4f 52 54 ABILITY, OR TORT
0310: 0a 3b 3b 20 28 49 4e 43 4c 55 44 49 4e 47 20 4e .;; (INCLUDING N
0320: 45 47 4c 49 47 45 4e 43 45 20 4f 52 20 4f 54 48 EGLIGENCE OR OTH
0330: 45 52 57 49 53 45 29 20 41 52 49 53 49 4e 47 20 ERWISE) ARISING
0340: 49 4e 20 41 4e 59 20 57 41 59 20 4f 55 54 20 4f IN ANY WAY OUT O
0350: 46 20 54 48 45 0a 3b 3b 20 55 53 45 20 4f 46 20 F THE.;; USE OF
0360: 54 48 49 53 20 53 4f 46 54 57 41 52 45 2c 20 45 THIS SOFTWARE, E
0370: 56 45 4e 20 49 46 20 41 44 56 49 53 45 44 20 4f VEN IF ADVISED O
0380: 46 20 54 48 45 20 50 4f 53 53 49 42 49 4c 49 54 F THE POSSIBILIT
0390: 59 20 4f 46 20 53 55 43 48 0a 3b 3b 20 44 41 4d Y OF SUCH.;; DAM
03a0: 41 47 45 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d AGE...;;========
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 3d 0a 3b ==============.;
03f0: 3b 20 41 42 4f 55 54 3a 0a 3b 3b 20 20 20 53 65 ; ABOUT:.;; Se
0400: 65 20 52 45 41 44 4d 45 20 69 6e 20 74 68 65 20 e README in the
0410: 64 69 73 74 72 69 62 75 74 69 6f 6e 20 61 74 20 distribution at
0420: 68 74 74 70 73 3a 2f 2f 77 77 77 2e 6b 69 61 74 https://www.kiat
0430: 6f 61 2e 63 6f 6d 2f 66 6f 73 73 69 6c 73 2f 75 oa.com/fossils/u
0440: 6c 65 78 0a 3b 3b 20 4e 4f 54 45 53 3a 0a 3b 3b lex.;; NOTES:.;;
0450: 20 20 20 57 68 79 20 73 71 6c 2d 64 65 2d 6c 69 Why sql-de-li
0460: 74 65 20 61 6e 64 20 6e 6f 74 20 73 61 79 2c 20 te and not say,
0470: 64 62 69 3f 20 20 2d 20 70 65 72 66 6f 72 6d 61 dbi? - performa
0480: 6e 63 65 20 6d 6f 73 74 6c 79 2c 20 74 68 65 6e nce mostly, then
0490: 20 73 69 6d 70 6c 69 63 69 74 79 2e 0a 3b 3b 0a simplicity..;;.
04a0: 3b 3b 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 3d 0a 0a 3b 3b 20 28 75 73 ========..;; (us
04f0: 65 20 72 70 63 20 70 6b 74 73 20 6d 61 69 6c 62 e rpc pkts mailb
0500: 6f 78 20 73 71 6c 69 74 65 33 29 0a 20 20 0a 28 ox sqlite3). .(
0510: 6d 6f 64 75 6c 65 20 75 6c 65 78 0a 20 20 20 20 module ulex.
0520: 2a 0a 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 6d *..(import schem
0530: 65 20 70 6f 73 69 78 20 63 68 69 63 6b 65 6e 20 e posix chicken
0540: 64 61 74 61 2d 73 74 72 75 63 74 75 72 65 73 20 data-structures
0550: 70 6f 72 74 73 20 65 78 74 72 61 73 20 66 69 6c ports extras fil
0560: 65 73 20 6d 61 69 6c 62 6f 78 29 0a 28 69 6d 70 es mailbox).(imp
0570: 6f 72 74 20 72 70 63 20 73 72 66 69 2d 31 38 20 ort rpc srfi-18
0580: 70 6b 74 73 20 6d 61 74 63 68 61 62 6c 65 20 72 pkts matchable r
0590: 65 67 65 78 0a 09 74 79 70 65 64 2d 72 65 63 6f egex..typed-reco
05a0: 72 64 73 20 73 72 66 69 2d 36 39 20 73 72 66 69 rds srfi-69 srfi
05b0: 2d 31 0a 09 73 72 66 69 2d 34 20 72 65 67 65 78 -1..srfi-4 regex
05c0: 2d 63 61 73 65 0a 09 28 70 72 65 66 69 78 20 73 -case..(prefix s
05d0: 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 qlite3 sqlite3:)
05e0: 0a 09 66 6f 72 65 69 67 6e 0a 09 74 63 70 29 20 ..foreign..tcp)
05f0: 3b 3b 20 75 6c 65 78 2d 6e 65 74 75 74 69 6c 29 ;; ulex-netutil)
0600: 0a 0a 3b 3b 20 6d 61 6b 65 20 69 74 20 61 20 67 ..;; make it a g
0610: 6c 6f 62 61 6c 3f 20 57 65 6c 6c 2c 20 69 74 20 lobal? Well, it
0620: 69 73 20 6c 6f 63 61 6c 20 74 6f 20 61 72 65 61 is local to area
0630: 20 6d 6f 64 75 6c 65 0a 0a 28 64 65 66 69 6e 65 module..(define
0640: 20 2a 63 61 70 74 61 69 6e 2d 70 6b 74 73 70 65 *captain-pktspe
0650: 63 2a 0a 20 20 60 28 28 63 61 70 74 61 69 6e 20 c*. `((captain
0660: 28 68 6f 73 74 20 20 20 20 20 2e 20 68 29 0a 09 (host . h)..
0670: 20 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 2e (port .
0680: 20 70 29 0a 09 20 20 20 20 20 28 70 69 64 20 20 p).. (pid
0690: 20 20 20 20 2e 20 69 29 0a 09 20 20 20 20 20 28 . i).. (
06a0: 69 70 61 64 64 72 20 20 20 2e 20 61 29 0a 09 20 ipaddr . a)..
06b0: 20 20 20 20 29 0a 20 20 20 20 23 3b 28 64 61 74 ). #;(dat
06c0: 61 20 20 20 28 68 6f 73 74 6e 61 6d 65 20 2e 20 a (hostname .
06d0: 68 29 20 20 3b 3b 20 73 65 6e 64 65 72 20 68 6f h) ;; sender ho
06e0: 73 74 6e 61 6d 65 0a 09 20 20 20 20 28 70 6f 72 stname.. (por
06f0: 74 20 20 20 20 20 2e 20 70 29 20 20 3b 3b 20 73 t . p) ;; s
0700: 65 6e 64 65 72 20 70 6f 72 74 0a 09 20 20 20 20 ender port..
0710: 28 69 70 61 64 64 72 20 20 20 2e 20 61 29 20 20 (ipaddr . a)
0720: 3b 3b 20 73 65 6e 64 65 72 20 69 70 0a 09 20 20 ;; sender ip..
0730: 20 20 28 68 6f 73 74 6b 65 79 20 20 2e 20 6b 29 (hostkey . k)
0740: 20 20 3b 3b 20 73 65 6e 64 69 6e 67 20 68 6f 73 ;; sending hos
0750: 74 20 6b 65 79 20 2d 20 73 74 6f 72 65 20 69 6e t key - store in
0760: 66 6f 20 61 74 20 73 65 72 76 65 72 20 75 6e 64 fo at server und
0770: 65 72 20 74 68 69 73 20 6b 65 79 0a 09 20 20 20 er this key..
0780: 20 28 73 65 72 76 6b 65 79 20 20 2e 20 73 29 20 (servkey . s)
0790: 20 3b 3b 20 73 65 72 76 65 72 20 6b 65 79 20 2d ;; server key -
07a0: 20 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 6d this needs to m
07b0: 61 74 63 68 20 61 74 20 73 65 72 76 65 72 20 65 atch at server e
07c0: 6e 64 20 6f 72 20 72 65 6a 65 63 74 20 74 68 65 nd or reject the
07d0: 20 6d 73 67 0a 09 20 20 20 20 28 66 6f 72 6d 61 msg.. (forma
07e0: 74 20 20 20 2e 20 66 29 20 20 3b 3b 20 73 62 3d t . f) ;; sb=
07f0: 73 65 72 69 61 6c 69 7a 65 64 2d 62 61 73 65 36 serialized-base6
0800: 34 2c 20 74 3d 74 65 78 74 2c 20 73 78 3d 73 65 4, t=text, sx=se
0810: 78 70 72 2c 20 6a 3d 6a 73 6f 6e 0a 09 20 20 20 xpr, j=json..
0820: 20 28 64 61 74 61 20 20 20 20 20 2e 20 64 29 20 (data . d)
0830: 20 3b 3b 20 62 61 73 65 36 34 20 65 6e 63 6f 64 ;; base64 encod
0840: 65 64 20 73 6c 6c 6e 20 64 61 74 61 0a 09 20 20 ed slln data..
0850: 20 20 29 29 29 0a 0a 28 64 65 66 73 74 72 75 63 )))..(defstruc
0860: 74 20 75 64 61 74 0a 20 20 28 63 61 70 74 61 69 t udat. (captai
0870: 6e 2d 61 64 64 72 65 73 73 20 23 66 29 0a 20 20 n-address #f).
0880: 28 63 61 70 74 61 69 6e 2d 68 6f 73 74 20 20 20 (captain-host
0890: 20 23 66 29 0a 20 20 28 63 61 70 74 61 69 6e 2d #f). (captain-
08a0: 70 6f 72 74 20 20 20 20 23 66 29 0a 20 20 28 63 port #f). (c
08b0: 61 70 74 61 69 6e 2d 70 69 64 20 20 20 20 20 23 aptain-pid #
08c0: 66 29 0a 20 20 28 63 70 6b 74 73 2d 64 69 72 20 f). (cpkts-dir
08d0: 20 20 20 20 20 20 28 63 6f 6e 63 20 28 67 65 74 (conc (get
08e0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
08f0: 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 20 22 2f iable "HOME") "/
0900: 2e 75 6c 65 78 2f 70 6b 74 73 22 29 29 0a 20 20 .ulex/pkts")).
0910: 28 63 70 6b 74 2d 73 70 65 63 20 20 20 20 20 20 (cpkt-spec
0920: 20 2a 63 61 70 74 61 69 6e 2d 70 6b 74 73 70 65 *captain-pktspe
0930: 63 2a 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 c*))..;; given a
0940: 20 70 6b 74 73 20 64 69 72 20 72 65 61 64 20 0a pkts dir read .
0950: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d ;;.(define (get-
0960: 61 6c 6c 2d 63 61 70 74 61 69 6e 2d 70 6b 74 73 all-captain-pkts
0970: 20 75 64 61 74 61 29 0a 20 20 28 6c 65 74 2a 20 udata). (let*
0980: 28 28 70 6b 74 73 64 69 72 20 20 20 20 20 20 20 ((pktsdir
0990: 28 6c 65 74 20 28 28 64 20 28 75 64 61 74 2d 63 (let ((d (udat-c
09a0: 70 6b 74 73 2d 64 69 72 20 75 64 61 74 61 29 29 pkts-dir udata))
09b0: 29 0a 09 09 09 20 20 28 69 66 20 28 66 69 6c 65 ).... (if (file
09c0: 2d 65 78 69 73 74 73 3f 20 64 29 0a 09 09 09 20 -exists? d)....
09d0: 20 20 20 20 20 64 0a 09 09 09 20 20 20 20 20 20 d....
09e0: 28 62 65 67 69 6e 0a 09 09 09 09 28 63 72 65 61 (begin.....(crea
09f0: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 64 20 23 te-directory d #
0a00: 74 29 0a 09 09 09 09 64 29 29 29 29 0a 09 20 28 t).....d)))).. (
0a10: 61 6c 6c 2d 70 6b 74 2d 66 69 6c 65 73 20 28 67 all-pkt-files (g
0a20: 6c 6f 62 20 28 63 6f 6e 63 20 70 6b 74 73 64 69 lob (conc pktsdi
0a30: 72 20 22 2f 2a 2e 70 6b 74 22 29 29 29 0a 09 20 r "/*.pkt")))..
0a40: 28 70 6b 74 2d 73 70 65 63 20 20 20 20 20 20 28 (pkt-spec (
0a50: 75 64 61 74 2d 63 70 6b 74 2d 73 70 65 63 20 75 udat-cpkt-spec u
0a60: 64 61 74 61 29 29 29 0a 20 20 20 20 28 6d 61 70 data))). (map
0a70: 20 28 6c 61 6d 62 64 61 20 28 70 6b 74 2d 66 69 (lambda (pkt-fi
0a80: 6c 65 29 0a 09 20 20 20 28 72 65 61 64 2d 70 6b le).. (read-pk
0a90: 74 2d 3e 61 6c 69 73 74 20 70 6b 74 2d 66 69 6c t->alist pkt-fil
0aa0: 65 20 70 6b 74 73 70 65 63 3a 20 70 6b 74 2d 73 e pktspec: pkt-s
0ab0: 70 65 63 29 29 0a 09 20 61 6c 6c 2d 70 6b 74 2d pec)).. all-pkt-
0ac0: 66 69 6c 65 73 29 29 29 0a 0a 3b 3b 20 73 6f 72 files)))..;; sor
0ad0: 74 20 62 79 20 44 20 74 68 65 6e 20 5a 2c 20 72 t by D then Z, r
0ae0: 65 74 75 72 6e 20 6f 6e 65 0a 28 64 65 66 69 6e eturn one.(defin
0af0: 65 20 28 67 65 74 2d 77 69 6e 6e 69 6e 67 2d 70 e (get-winning-p
0b00: 6b 74 20 70 6b 74 73 29 0a 20 20 28 69 66 20 28 kt pkts). (if (
0b10: 6e 75 6c 6c 3f 20 70 6b 74 73 29 0a 20 20 20 20 null? pkts).
0b20: 20 20 23 66 0a 20 20 20 20 20 20 28 63 61 72 20 #f. (car
0b30: 28 73 6f 72 74 20 70 6b 74 73 20 28 6c 61 6d 62 (sort pkts (lamb
0b40: 64 61 20 28 61 20 62 29 0a 09 09 09 28 6c 65 74 da (a b)....(let
0b50: 20 28 28 61 64 20 28 61 6c 69 73 74 2d 72 65 66 ((ad (alist-ref
0b60: 20 27 44 20 61 29 29 0a 09 09 09 20 20 20 20 20 'D a))....
0b70: 20 28 62 64 20 28 61 6c 69 73 74 2d 72 65 66 20 (bd (alist-ref
0b80: 27 44 20 62 29 29 29 0a 09 09 09 20 20 28 69 66 'D b))).... (if
0b90: 20 28 65 71 3f 20 61 20 62 29 0a 09 09 09 20 20 (eq? a b)....
0ba0: 20 20 20 20 28 6c 65 74 20 28 28 61 7a 20 28 61 (let ((az (a
0bb0: 6c 69 73 74 2d 72 65 66 20 27 5a 20 61 29 29 0a list-ref 'Z a)).
0bc0: 09 09 09 09 20 20 20 20 28 62 7a 20 28 61 6c 69 .... (bz (ali
0bd0: 73 74 2d 72 65 66 20 27 5a 20 62 29 29 29 0a 09 st-ref 'Z b)))..
0be0: 09 09 09 28 73 74 72 69 6e 67 3e 3d 3f 20 61 7a ...(string>=? az
0bf0: 20 62 7a 29 29 0a 09 09 09 20 20 20 20 20 20 28 bz)).... (
0c00: 3e 20 61 64 20 62 64 29 29 29 29 29 29 29 29 0a > ad bd)))))))).
0c10: 0a 3b 3b 20 66 69 6e 64 20 6f 72 20 62 65 63 6f .;; find or beco
0c20: 6d 65 20 74 68 65 20 63 61 70 74 61 69 6e 2c 20 me the captain,
0c30: 72 65 74 75 72 6e 20 61 20 75 6c 65 78 20 6f 62 return a ulex ob
0c40: 6a 65 63 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ject.;;.(define
0c50: 28 73 65 74 75 70 29 0a 20 20 28 6c 65 74 2a 20 (setup). (let*
0c60: 28 28 75 64 61 74 61 20 28 6d 61 6b 65 2d 75 64 ((udata (make-ud
0c70: 61 74 29 29 0a 09 20 28 63 70 6b 74 73 20 28 67 at)).. (cpkts (g
0c80: 65 74 2d 61 6c 6c 2d 63 61 70 74 61 69 6e 2d 70 et-all-captain-p
0c90: 6b 74 73 20 75 64 61 74 61 29 29 20 3b 3b 20 72 kts udata)) ;; r
0ca0: 65 61 64 20 63 61 70 74 61 69 6e 20 70 6b 74 73 ead captain pkts
0cb0: 0a 09 20 28 63 61 70 74 6e 20 28 67 65 74 2d 77 .. (captn (get-w
0cc0: 69 6e 6e 69 6e 67 2d 70 6b 74 20 63 70 6b 74 73 inning-pkt cpkts
0cd0: 29 29 29 0a 20 20 20 20 28 69 66 20 63 61 70 74 ))). (if capt
0ce0: 6e 0a 09 28 6c 65 74 2a 20 28 28 70 6f 72 74 20 n..(let* ((port
0cf0: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 70 6f (alist-ref 'po
0d00: 72 74 20 20 20 63 61 70 74 6e 29 29 0a 09 20 20 rt captn))..
0d10: 20 20 20 20 20 28 68 6f 73 74 20 20 20 28 61 6c (host (al
0d20: 69 73 74 2d 72 65 66 20 27 68 6f 73 74 20 20 20 ist-ref 'host
0d30: 63 61 70 74 6e 29 29 0a 09 20 20 20 20 20 20 20 captn))..
0d40: 28 69 70 61 64 64 72 20 28 61 6c 69 73 74 2d 72 (ipaddr (alist-r
0d50: 65 66 20 27 69 70 61 64 64 72 20 63 61 70 74 6e ef 'ipaddr captn
0d60: 29 29 0a 09 20 20 20 20 20 20 20 28 70 69 64 20 )).. (pid
0d70: 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 70 (alist-ref 'p
0d80: 69 64 20 20 20 20 63 61 70 74 6e 29 29 29 0a 09 id captn)))..
0d90: 20 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d (udat-captain-
0da0: 61 64 64 72 65 73 73 2d 73 65 74 21 20 75 64 61 address-set! uda
0db0: 74 61 20 69 70 61 64 64 72 29 0a 09 20 20 28 75 ta ipaddr).. (u
0dc0: 64 61 74 2d 63 61 70 74 61 69 6e 2d 68 6f 73 74 dat-captain-host
0dd0: 2d 73 65 74 21 20 20 20 20 75 64 61 74 61 20 68 -set! udata h
0de0: 6f 73 74 29 0a 09 20 20 28 75 64 61 74 2d 63 61 ost).. (udat-ca
0df0: 70 74 61 69 6e 2d 70 6f 72 74 2d 73 65 74 21 20 ptain-port-set!
0e00: 20 20 20 75 64 61 74 61 20 70 6f 72 74 29 0a 09 udata port)..
0e10: 20 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e 2d (udat-captain-
0e20: 70 69 64 2d 73 65 74 21 20 20 20 20 20 75 64 61 pid-set! uda
0e30: 74 61 20 70 69 64 29 0a 09 20 20 75 64 61 74 61 ta pid).. udata
0e40: 29 0a 09 3b 3b 0a 09 3b 3b 20 72 65 67 69 73 74 )..;;..;; regist
0e50: 65 72 20 63 61 70 74 6e 20 68 65 72 65 0a 09 3b er captn here..;
0e60: 3b 0a 09 3b 3b 20 20 74 68 65 6e 20 72 75 6e 20 ;..;; then run
0e70: 73 65 74 75 70 20 61 67 61 69 6e 0a 09 3b 3b 0a setup again..;;.
0e80: 09 75 64 61 74 61 0a 09 29 29 29 0a 20 20 20 20 .udata..))).
0e90: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 6e 65 63 .(define (connec
0ea0: 74 20 75 64 61 74 61 20 64 62 66 6e 61 6d 65 29 t udata dbfname)
0eb0: 0a 20 20 75 64 61 74 61 29 0a 0a 3b 3b 3b 20 3b . udata)..;;; ;
0ec0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
0ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ee0: 3d 3d 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 0a 3b 3b 3b 20 3b 3b 20 44 =======.;;; ;; D
0f10: 20 45 20 42 20 55 20 47 20 20 20 48 20 45 20 4c E B U G H E L
0f20: 20 50 20 45 20 52 20 53 0a 3b 3b 3b 20 3b 3b 3d P E R S.;;; ;;=
0f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f70: 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 20 20 20 20 0a 3b =====.;;; .;
0f80: 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 62 67 3e ;; (define (dbg>
0f90: 20 2e 20 61 72 67 73 29 0a 3b 3b 3b 20 20 20 28 . args).;;; (
0fa0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 with-output-to-p
0fb0: 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ort (current-err
0fc0: 6f 72 2d 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 20 or-port).;;;
0fd0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 (lambda ().;;;
0fe0: 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 (apply pri
0ff0: 6e 74 20 22 64 62 67 3e 20 22 20 61 72 67 73 29 nt "dbg> " args)
1000: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 ))).;;; .;;; (de
1010: 66 69 6e 65 20 28 64 65 62 75 67 2d 70 70 20 2e fine (debug-pp .
1020: 20 61 72 67 73 29 0a 3b 3b 3b 20 20 20 28 69 66 args).;;; (if
1030: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
1040: 74 2d 76 61 72 69 61 62 6c 65 20 22 55 4c 45 58 t-variable "ULEX
1050: 5f 44 45 42 55 47 22 29 0a 3b 3b 3b 20 20 20 20 _DEBUG").;;;
1060: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
1070: 74 6f 2d 70 6f 72 74 20 28 63 75 72 72 65 6e 74 to-port (current
1080: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 0a 3b 3b 3b -error-port).;;;
1090: 20 09 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b .(lambda ().;;;
10a0: 20 09 20 20 28 61 70 70 6c 79 20 70 70 20 61 72 . (apply pp ar
10b0: 67 73 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b gs))))).;;; .;;;
10c0: 20 28 64 65 66 69 6e 65 20 2a 64 65 66 61 75 6c (define *defaul
10d0: 74 2d 64 65 62 75 67 2d 70 6f 72 74 2a 20 28 63 t-debug-port* (c
10e0: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
10f0: 74 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 t)).;;; .;;; (de
1100: 66 69 6e 65 20 28 73 64 62 67 3e 20 66 6e 20 73 fine (sdbg> fn s
1110: 74 61 67 65 2d 6e 61 6d 65 20 73 74 61 67 65 2d tage-name stage-
1120: 73 74 61 72 74 20 73 74 61 67 65 2d 65 6e 64 20 start stage-end
1130: 73 74 61 72 74 2d 74 69 6d 65 20 2e 20 6d 65 73 start-time . mes
1140: 73 61 67 65 29 0a 3b 3b 3b 20 20 20 28 69 66 20 sage).;;; (if
1150: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
1160: 2d 76 61 72 69 61 62 6c 65 20 22 55 4c 45 58 5f -variable "ULEX_
1170: 44 45 42 55 47 22 29 0a 3b 3b 3b 20 20 20 20 20 DEBUG").;;;
1180: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
1190: 6f 2d 70 6f 72 74 20 2a 64 65 66 61 75 6c 74 2d o-port *default-
11a0: 64 65 62 75 67 2d 70 6f 72 74 2a 20 0a 3b 3b 3b debug-port* .;;;
11b0: 20 09 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b .(lambda ().;;;
11c0: 20 09 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 . (apply print
11d0: 20 22 75 6c 65 78 3a 22 20 66 6e 20 22 20 22 20 "ulex:" fn " "
11e0: 73 74 61 67 65 2d 6e 61 6d 65 20 22 20 74 6f 6f stage-name " too
11f0: 6b 20 22 20 28 2d 20 28 69 66 20 73 74 61 67 65 k " (- (if stage
1200: 2d 65 6e 64 20 73 74 61 67 65 2d 65 6e 64 20 28 -end stage-end (
1210: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
1220: 6f 6e 64 73 29 29 20 73 74 61 67 65 2d 73 74 61 onds)) stage-sta
1230: 72 74 29 20 22 20 6d 73 2e 20 22 0a 3b 3b 3b 20 rt) " ms. ".;;;
1240: 09 09 20 28 69 66 20 73 74 61 72 74 2d 74 69 6d .. (if start-tim
1250: 65 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 63 6f e.;;; .. (co
1260: 6e 63 20 22 74 6f 74 61 6c 20 74 69 6d 65 20 22 nc "total time "
1270: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c (- (current-mil
1280: 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 liseconds) start
1290: 2d 74 69 6d 65 29 0a 3b 3b 3b 20 09 09 09 20 20 -time).;;; ...
12a0: 20 22 20 6d 73 2e 22 29 0a 3b 3b 3b 20 09 09 20 " ms.").;;; ..
12b0: 20 20 20 20 22 22 29 0a 3b 3b 3b 20 09 09 20 6d "").;;; .. m
12c0: 65 73 73 61 67 65 0a 3b 3b 3b 20 09 09 20 29 29 essage.;;; .. ))
12d0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
12e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
1320: 20 4d 20 41 20 43 20 52 20 4f 20 53 0a 3b 3b 3d M A C R O S.;;=
1330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1370: 3d 3d 3d 3d 3d 0a 3b 3b 20 69 75 70 20 63 61 6c =====.;; iup cal
1380: 6c 62 61 63 6b 73 20 61 72 65 20 6e 6f 74 20 64 lbacks are not d
1390: 75 6d 70 69 6e 67 20 74 68 65 20 73 74 61 63 6b umping the stack
13a0: 2c 20 74 68 69 73 20 69 73 20 61 20 77 6f 72 6b , this is a work
13b0: 2d 61 72 6f 75 6e 64 0a 3b 3b 0a 0a 3b 3b 20 53 -around.;;..;; S
13c0: 6f 6d 65 20 6f 66 20 74 68 65 73 65 20 72 6f 75 ome of these rou
13d0: 74 69 6e 65 73 20 75 73 65 3a 0a 3b 3b 0a 3b 3b tines use:.;;.;;
13e0: 20 20 20 20 20 68 74 74 70 3a 2f 2f 77 77 77 2e http://www.
13f0: 63 73 2e 74 6f 72 6f 6e 74 6f 2e 65 64 75 2f 7e cs.toronto.edu/~
1400: 67 66 62 2f 73 63 68 65 6d 65 2f 73 69 6d 70 6c gfb/scheme/simpl
1410: 65 2d 6d 61 63 72 6f 73 2e 68 74 6d 6c 0a 3b 3b e-macros.html.;;
1420: 0a 3b 3b 20 53 79 6e 74 61 78 20 66 6f 72 20 64 .;; Syntax for d
1430: 65 66 69 6e 69 6e 67 20 6d 61 63 72 6f 73 20 69 efining macros i
1440: 6e 20 61 20 73 69 6d 70 6c 65 20 73 74 79 6c 65 n a simple style
1450: 20 73 69 6d 69 6c 61 72 20 74 6f 20 66 75 6e 63 similar to func
1460: 74 69 6f 6e 20 64 65 66 69 6e 69 74 6f 6e 2c 0a tion definiton,.
1470: 3b 3b 20 20 77 68 65 6e 20 74 68 65 72 65 20 69 ;; when there i
1480: 73 20 61 20 73 69 6e 67 6c 65 20 70 61 74 74 65 s a single patte
1490: 72 6e 20 66 6f 72 20 74 68 65 20 61 72 67 75 6d rn for the argum
14a0: 65 6e 74 20 6c 69 73 74 20 61 6e 64 20 74 68 65 ent list and the
14b0: 72 65 20 61 72 65 20 6e 6f 20 6b 65 79 77 6f 72 re are no keywor
14c0: 64 73 2e 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e ds..;;.;; (defin
14d0: 65 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 61 78 20 e-simple-syntax
14e0: 28 6e 61 6d 65 20 61 72 67 20 2e 2e 2e 29 20 62 (name arg ...) b
14f0: 6f 64 79 20 2e 2e 2e 29 0a 3b 3b 0a 0a 28 64 65 ody ...).;;..(de
1500: 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 66 69 fine-syntax defi
1510: 6e 65 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 61 78 ne-simple-syntax
1520: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
1530: 20 28 29 0a 20 20 20 20 28 28 5f 20 28 6e 61 6d (). ((_ (nam
1540: 65 20 61 72 67 20 2e 2e 2e 29 20 62 6f 64 79 20 e arg ...) body
1550: 2e 2e 2e 29 0a 20 20 20 20 20 28 64 65 66 69 6e ...). (defin
1560: 65 2d 73 79 6e 74 61 78 20 6e 61 6d 65 20 28 73 e-syntax name (s
1570: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 20 28 yntax-rules () (
1580: 28 6e 61 6d 65 20 61 72 67 20 2e 2e 2e 29 20 28 (name arg ...) (
1590: 62 65 67 69 6e 20 62 6f 64 79 20 2e 2e 2e 29 29 begin body ...))
15a0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 )))))..(define-s
15b0: 69 6d 70 6c 65 2d 73 79 6e 74 61 78 20 28 63 61 imple-syntax (ca
15c0: 74 63 68 2d 61 6e 64 2d 64 75 6d 70 20 70 72 6f tch-and-dump pro
15d0: 63 20 70 72 6f 63 6e 61 6d 65 29 0a 20 20 28 68 c procname). (h
15e0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
15f0: 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 65 67 69 . exn. (begi
1600: 6e 0a 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 n. (print-ca
1610: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
1620: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 t-error-port)).
1630: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
1640: 2d 74 6f 2d 70 6f 72 74 20 28 63 75 72 72 65 6e -to-port (curren
1650: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 0a 20 20 t-error-port).
1660: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
1670: 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 (print
1680: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
1690: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
16a0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
16b0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 72 69 )). (pri
16c0: 6e 74 20 22 43 61 6c 6c 62 61 63 6b 20 65 72 72 nt "Callback err
16d0: 6f 72 20 69 6e 20 22 20 70 72 6f 63 6e 61 6d 65 or in " procname
16e0: 29 0a 20 20 20 20 20 20 20 20 20 28 70 72 69 6e ). (prin
16f0: 74 20 22 46 75 6c 6c 20 63 6f 6e 64 69 74 69 6f t "Full conditio
1700: 6e 20 69 6e 66 6f 3a 5c 6e 22 20 28 63 6f 6e 64 n info:\n" (cond
1710: 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 ition->list exn)
1720: 29 29 29 29 0a 20 20 20 28 70 72 6f 63 29 29 29 )))). (proc)))
1730: 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ...;;===========
1740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
1780: 52 20 45 20 43 20 4f 20 52 20 44 20 53 0a 3b 3b R E C O R D S.;;
1790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17d0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3b 20 3b 3b 20 69 ======..;;; ;; i
17e0: 6e 66 6f 72 6d 61 74 69 6f 6e 20 61 62 6f 75 74 nformation about
17f0: 20 6d 65 20 61 73 20 61 20 73 65 72 76 65 72 0a me as a server.
1800: 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 73 ;;; ;;.;;; (defs
1810: 74 72 75 63 74 20 61 72 65 61 0a 3b 3b 3b 20 20 truct area.;;;
1820: 20 3b 3b 20 61 62 6f 75 74 20 74 68 69 73 20 61 ;; about this a
1830: 72 65 61 0a 3b 3b 3b 20 20 20 28 75 73 65 70 6f rea.;;; (usepo
1840: 72 74 6c 6f 67 67 65 72 20 23 66 29 0a 3b 3b 3b rtlogger #f).;;;
1850: 20 20 20 28 6c 6f 77 70 6f 72 74 20 20 20 20 20 (lowport
1860: 20 20 33 32 37 36 38 29 0a 3b 3b 3b 20 20 20 28 32768).;;; (
1870: 73 65 72 76 65 72 2d 74 79 70 65 20 20 20 27 61 server-type 'a
1880: 75 74 6f 29 20 20 3b 3b 20 61 75 74 6f 3d 63 72 uto) ;; auto=cr
1890: 65 61 74 65 20 75 70 20 74 6f 20 66 69 76 65 20 eate up to five
18a0: 73 65 72 76 65 72 73 2f 70 6b 74 73 2c 20 6d 61 servers/pkts, ma
18b0: 69 6e 3d 63 72 65 61 74 65 20 70 6b 74 73 2c 20 in=create pkts,
18c0: 70 61 73 73 69 76 65 3d 6e 6f 20 70 6b 74 20 28 passive=no pkt (
18d0: 75 6e 6c 65 73 73 20 74 68 65 72 65 20 61 72 65 unless there are
18e0: 20 6e 6f 20 70 6b 74 73 20 61 74 20 61 6c 6c 29 no pkts at all)
18f0: 0a 3b 3b 3b 20 20 20 28 63 6f 6e 6e 20 20 20 20 .;;; (conn
1900: 20 20 20 20 20 20 23 66 29 0a 3b 3b 3b 20 20 20 #f).;;;
1910: 28 70 6f 72 74 20 20 20 20 20 20 20 20 20 20 23 (port #
1920: 66 29 0a 3b 3b 3b 20 20 20 28 6d 79 61 64 64 72 f).;;; (myaddr
1930: 20 20 20 20 20 20 20 20 28 67 65 74 2d 6d 79 2d (get-my-
1940: 62 65 73 74 2d 61 64 64 72 65 73 73 29 29 0a 3b best-address)).;
1950: 3b 3b 20 20 20 70 6b 74 69 64 20 20 20 20 20 20 ;; pktid
1960: 20 20 20 20 3b 3b 20 67 65 74 20 70 6b 74 20 66 ;; get pkt f
1970: 72 6f 6d 20 68 6f 73 74 73 20 74 61 62 6c 65 20 rom hosts table
1980: 69 66 20 6e 65 65 64 65 64 0a 3b 3b 3b 20 20 20 if needed.;;;
1990: 70 6b 74 66 69 6c 65 0a 3b 3b 3b 20 20 20 70 6b pktfile.;;; pk
19a0: 74 73 64 69 72 0a 3b 3b 3b 20 20 20 64 62 64 69 tsdir.;;; dbdi
19b0: 72 0a 3b 3b 3b 20 20 20 28 64 62 68 61 6e 64 6c r.;;; (dbhandl
19c0: 65 73 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 es (make-has
19d0: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 66 6e 61 h-table)) ;; fna
19e0: 6d 65 20 3d 3e 20 6c 69 73 74 2d 6f 66 2d 64 62 me => list-of-db
19f0: 68 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 6c 64 20 h, NOTE: Should
1a00: 72 65 61 6c 6c 79 20 6e 65 76 65 72 20 6e 65 65 really never nee
1a10: 64 20 6d 6f 72 65 20 74 68 61 6e 20 6f 6e 65 3f d more than one?
1a20: 0a 3b 3b 3b 20 20 20 28 6d 75 74 65 78 20 20 20 .;;; (mutex
1a30: 20 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 (make-mute
1a40: 78 29 29 0a 3b 3b 3b 20 20 20 28 72 74 61 62 6c x)).;;; (rtabl
1a50: 65 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 e (make-h
1a60: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 72 ash-table)) ;; r
1a70: 65 67 69 73 74 72 61 74 69 6f 6e 20 74 61 62 6c egistration tabl
1a80: 65 20 6f 66 20 61 76 61 69 6c 61 62 6c 65 20 61 e of available a
1a90: 63 74 69 6f 6e 73 0a 3b 3b 3b 20 20 20 28 64 62 ctions.;;; (db
1aa0: 73 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b s (mak
1ab0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
1ac0: 3b 20 66 69 6c 65 6e 61 6d 65 20 3d 3e 20 72 61 ; filename => ra
1ad0: 6e 64 6f 6d 20 6e 75 6d 62 65 72 2c 20 75 73 65 ndom number, use
1ae0: 64 20 66 6f 72 20 63 68 6f 6f 73 69 6e 67 20 77 d for choosing w
1af0: 68 61 74 20 64 62 73 20 49 20 73 65 72 76 65 0a hat dbs I serve.
1b00: 3b 3b 3b 20 20 20 3b 3b 20 61 62 6f 75 74 20 6f ;;; ;; about o
1b10: 74 68 65 72 20 73 65 72 76 65 72 73 0a 3b 3b 3b ther servers.;;;
1b20: 20 20 20 28 68 6f 73 74 73 20 20 20 20 20 20 20 (hosts
1b30: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
1b40: 6c 65 29 29 20 3b 3b 20 6b 65 79 20 3d 3e 20 68 le)) ;; key => h
1b50: 6f 73 74 64 61 74 0a 3b 3b 3b 20 20 20 28 68 6f ostdat.;;; (ho
1b60: 73 74 73 74 61 74 73 20 20 20 20 20 28 6d 61 6b ststats (mak
1b70: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
1b80: 3b 20 6b 65 79 20 3d 3e 20 61 6c 69 73 74 20 6f ; key => alist o
1b90: 66 20 66 6e 61 6d 65 20 3d 3e 20 28 20 71 63 6f f fname => ( qco
1ba0: 75 6e 74 20 2e 20 71 74 69 6d 65 20 29 0a 3b 3b unt . qtime ).;;
1bb0: 3b 20 20 20 28 72 65 71 73 20 20 20 20 20 20 20 ; (reqs
1bc0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
1bd0: 62 6c 65 29 29 20 3b 3b 20 75 72 69 20 3d 3e 20 ble)) ;; uri =>
1be0: 71 75 65 75 65 0a 3b 3b 3b 20 20 20 3b 3b 20 77 queue.;;; ;; w
1bf0: 6f 72 6b 20 71 75 65 75 65 73 0a 3b 3b 3b 20 20 ork queues.;;;
1c00: 20 28 77 71 75 65 75 65 73 20 20 20 20 20 20 20 (wqueues
1c10: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1c20: 29 29 20 3b 3b 20 66 6e 61 6d 65 20 3d 3e 20 71 )) ;; fname => q
1c30: 64 61 74 0a 3b 3b 3b 20 20 20 28 73 74 61 74 73 dat.;;; (stats
1c40: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1c50: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 66 ash-table)) ;; f
1c60: 6e 61 6d 65 20 3d 3e 20 74 6f 74 61 6c 71 75 65 name => totalque
1c70: 72 69 65 73 0a 3b 3b 3b 20 20 20 28 6c 61 73 74 ries.;;; (last
1c80: 2d 73 72 76 75 70 20 20 20 20 28 63 75 72 72 65 -srvup (curre
1c90: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b 3b 20 nt-seconds)) ;;
1ca0: 6c 61 73 74 20 74 69 6d 65 20 77 65 20 75 70 64 last time we upd
1cb0: 61 74 65 64 20 74 68 65 20 6b 6e 6f 77 6e 20 73 ated the known s
1cc0: 65 72 76 65 72 73 0a 3b 3b 3b 20 20 20 28 63 6f ervers.;;; (co
1cd0: 6f 6b 69 65 32 6d 62 6f 78 20 20 20 28 6d 61 6b okie2mbox (mak
1ce0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
1cf0: 3b 20 6d 61 70 20 63 6f 6f 6b 69 65 20 66 6f 72 ; map cookie for
1d00: 20 6f 75 74 73 74 61 6e 64 69 6e 67 20 72 65 71 outstanding req
1d10: 75 65 73 74 20 74 6f 20 6d 61 69 6c 62 6f 78 20 uest to mailbox
1d20: 6f 66 20 61 77 61 69 74 69 6e 67 20 63 61 6c 6c of awaiting call
1d30: 0a 3b 3b 3b 20 20 20 28 72 65 61 64 79 20 23 66 .;;; (ready #f
1d40: 29 0a 3b 3b 3b 20 20 20 28 68 65 61 6c 74 68 20 ).;;; (health
1d50: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
1d60: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 69 70 61 h-table)) ;; ipa
1d70: 64 64 72 3a 70 6f 72 74 20 3d 3e 20 6e 75 6d 20 ddr:port => num
1d80: 66 61 69 6c 65 64 20 70 69 6e 67 73 20 73 69 6e failed pings sin
1d90: 63 65 20 6c 61 73 74 20 67 6f 6f 64 20 70 69 6e ce last good pin
1da0: 67 0a 3b 3b 3b 20 20 20 29 0a 3b 3b 3b 20 0a 3b g.;;; ).;;; .;
1db0: 3b 3b 20 3b 3b 20 68 6f 73 74 20 73 74 61 74 73 ;; ;; host stats
1dc0: 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 .;;; ;;.;;; (def
1dd0: 73 74 72 75 63 74 20 68 6f 73 74 64 61 74 0a 3b struct hostdat.;
1de0: 3b 3b 20 20 20 28 70 6b 74 20 20 20 20 20 20 23 ;; (pkt #
1df0: 66 29 0a 3b 3b 3b 20 20 20 28 64 62 6c 6f 61 64 f).;;; (dbload
1e00: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
1e10: 62 6c 65 29 29 20 20 3b 3b 20 22 64 62 66 69 6c ble)) ;; "dbfil
1e20: 65 2e 64 62 22 20 3d 3e 20 71 75 65 72 69 65 73 e.db" => queries
1e30: 2f 6d 69 6e 0a 3b 3b 3b 20 20 20 28 68 6f 73 74 /min.;;; (host
1e40: 6c 6f 61 64 20 23 66 29 20 20 20 20 20 20 20 20 load #f)
1e50: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 72 6d ;; norm
1e60: 61 6c 69 7a 65 64 20 6c 6f 61 64 20 28 20 35 6d alized load ( 5m
1e70: 69 6e 20 6c 6f 61 64 20 2f 20 6e 75 6d 63 70 75 in load / numcpu
1e80: 73 20 29 0a 3b 3b 3b 20 20 20 29 0a 3b 3b 3b 20 s ).;;; ).;;;
1e90: 0a 3b 3b 3b 20 3b 3b 20 64 62 64 61 74 0a 3b 3b .;;; ;; dbdat.;;
1ea0: 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 73 74 72 ; ;;.;;; (defstr
1eb0: 75 63 74 20 64 62 64 61 74 0a 3b 3b 3b 20 20 20 uct dbdat.;;;
1ec0: 28 64 62 68 20 20 20 20 23 66 29 0a 3b 3b 3b 20 (dbh #f).;;;
1ed0: 20 20 28 66 6e 61 6d 65 20 20 23 66 29 0a 3b 3b (fname #f).;;
1ee0: 3b 20 20 20 28 77 72 69 74 65 2d 61 63 63 65 73 ; (write-acces
1ef0: 73 20 23 66 29 0a 3b 3b 3b 20 20 20 28 73 74 68 s #f).;;; (sth
1f00: 73 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 s (make-hash-t
1f10: 61 62 6c 65 29 29 20 20 3b 3b 20 68 61 73 68 20 able)) ;; hash
1f20: 6d 61 70 70 69 6e 67 20 71 75 65 72 79 20 73 74 mapping query st
1f30: 72 69 6e 67 73 20 74 6f 20 68 61 6e 64 6c 65 73 rings to handles
1f40: 0a 3b 3b 3b 20 20 20 29 0a 3b 3b 3b 20 0a 3b 3b .;;; ).;;; .;;
1f50: 3b 20 3b 3b 20 71 64 61 74 0a 3b 3b 3b 20 3b 3b ; ;; qdat.;;; ;;
1f60: 0a 3b 3b 3b 20 28 64 65 66 73 74 72 75 63 74 20 .;;; (defstruct
1f70: 71 64 61 74 0a 3b 3b 3b 20 20 20 28 77 72 69 74 qdat.;;; (writ
1f80: 65 71 20 20 28 6d 61 6b 65 2d 71 75 65 75 65 29 eq (make-queue)
1f90: 29 0a 3b 3b 3b 20 20 20 28 72 65 61 64 71 20 20 ).;;; (readq
1fa0: 20 28 6d 61 6b 65 2d 71 75 65 75 65 29 29 0a 3b (make-queue)).;
1fb0: 3b 3b 20 20 20 28 72 77 71 20 20 20 20 20 28 6d ;; (rwq (m
1fc0: 61 6b 65 2d 71 75 65 75 65 29 29 0a 3b 3b 3b 20 ake-queue)).;;;
1fd0: 20 20 28 6c 6f 67 71 20 20 20 20 28 6d 61 6b 65 (logq (make
1fe0: 2d 71 75 65 75 65 29 29 20 3b 3b 20 64 6f 20 77 -queue)) ;; do w
1ff0: 65 20 6e 65 65 64 20 61 20 71 75 65 75 65 20 66 e need a queue f
2000: 6f 72 20 6c 6f 67 67 69 6e 67 3f 20 79 65 73 2c or logging? yes,
2010: 20 69 66 20 77 65 20 75 73 65 20 73 71 6c 69 74 if we use sqlit
2020: 65 33 20 64 62 20 66 6f 72 20 6c 6f 67 67 69 6e e3 db for loggin
2030: 67 0a 3b 3b 3b 20 20 20 28 6f 73 73 68 6f 72 74 g.;;; (osshort
2040: 20 28 6d 61 6b 65 2d 71 75 65 75 65 29 29 0a 3b (make-queue)).;
2050: 3b 3b 20 20 20 28 6f 73 6c 6f 6e 67 20 20 28 6d ;; (oslong (m
2060: 61 6b 65 2d 71 75 65 75 65 29 29 0a 3b 3b 3b 20 ake-queue)).;;;
2070: 20 20 28 6d 69 73 63 20 20 20 20 28 6d 61 6b 65 (misc (make
2080: 2d 71 75 65 75 65 29 29 20 3b 3b 20 75 73 65 64 -queue)) ;; used
2090: 20 66 6f 72 20 74 68 69 6e 67 73 20 6c 69 6b 65 for things like
20a0: 20 70 69 6e 67 2d 66 75 6c 6c 0a 3b 3b 3b 20 20 ping-full.;;;
20b0: 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 63 ).;;; .;;; ;; c
20c0: 61 6c 6c 64 61 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b alldat.;;; ;;.;;
20d0: 3b 20 28 64 65 66 73 74 72 75 63 74 20 63 61 6c ; (defstruct cal
20e0: 6c 64 61 74 0a 3b 3b 3b 20 20 20 28 63 74 79 70 ldat.;;; (ctyp
20f0: 65 20 27 64 62 77 72 69 74 65 29 0a 3b 3b 3b 20 e 'dbwrite).;;;
2100: 20 20 28 6f 62 6a 20 20 20 23 66 29 20 20 20 20 (obj #f)
2110: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 69 ;; thi
2120: 73 20 77 6f 75 6c 64 20 6e 6f 72 6d 61 6c 6c 79 s would normally
2130: 20 62 65 20 61 6e 20 53 51 4c 20 73 74 61 74 65 be an SQL state
2140: 6d 65 6e 74 20 65 2e 67 2e 20 53 45 4c 45 43 54 ment e.g. SELECT
2150: 2c 20 49 4e 53 45 52 54 20 65 74 63 2e 0a 3b 3b , INSERT etc..;;
2160: 3b 20 20 20 28 72 74 69 6d 65 20 28 63 75 72 72 ; (rtime (curr
2170: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
2180: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 ))).;;; .;;; ;;
2190: 6d 61 6b 65 20 69 74 20 61 20 67 6c 6f 62 61 6c make it a global
21a0: 3f 20 57 65 6c 6c 2c 20 69 74 20 69 73 20 6c 6f ? Well, it is lo
21b0: 63 61 6c 20 74 6f 20 61 72 65 61 20 6d 6f 64 75 cal to area modu
21c0: 6c 65 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 le.;;; .;;; (def
21d0: 69 6e 65 20 2a 70 6b 74 73 70 65 63 2a 0a 3b 3b ine *pktspec*.;;
21e0: 3b 20 20 20 60 28 28 73 65 72 76 65 72 20 28 68 ; `((server (h
21f0: 6f 73 74 6e 61 6d 65 20 2e 20 68 29 0a 3b 3b 3b ostname . h).;;;
2200: 20 09 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 . (port
2210: 2e 20 70 29 0a 3b 3b 3b 20 09 20 20 20 20 28 70 . p).;;; . (p
2220: 69 64 20 20 20 20 20 20 2e 20 69 29 0a 3b 3b 3b id . i).;;;
2230: 20 09 20 20 20 20 28 69 70 61 64 64 72 20 20 20 . (ipaddr
2240: 2e 20 61 29 0a 3b 3b 3b 20 09 20 20 20 20 29 0a . a).;;; . ).
2250: 3b 3b 3b 20 20 20 20 20 28 64 61 74 61 20 20 20 ;;; (data
2260: 28 68 6f 73 74 6e 61 6d 65 20 2e 20 68 29 20 20 (hostname . h)
2270: 3b 3b 20 73 65 6e 64 65 72 20 68 6f 73 74 6e 61 ;; sender hostna
2280: 6d 65 0a 3b 3b 3b 20 09 20 20 20 20 28 70 6f 72 me.;;; . (por
2290: 74 20 20 20 20 20 2e 20 70 29 20 20 3b 3b 20 73 t . p) ;; s
22a0: 65 6e 64 65 72 20 70 6f 72 74 0a 3b 3b 3b 20 09 ender port.;;; .
22b0: 20 20 20 20 28 69 70 61 64 64 72 20 20 20 2e 20 (ipaddr .
22c0: 61 29 20 20 3b 3b 20 73 65 6e 64 65 72 20 69 70 a) ;; sender ip
22d0: 0a 3b 3b 3b 20 09 20 20 20 20 28 68 6f 73 74 6b .;;; . (hostk
22e0: 65 79 20 20 2e 20 6b 29 20 20 3b 3b 20 73 65 6e ey . k) ;; sen
22f0: 64 69 6e 67 20 68 6f 73 74 20 6b 65 79 20 2d 20 ding host key -
2300: 73 74 6f 72 65 20 69 6e 66 6f 20 61 74 20 73 65 store info at se
2310: 72 76 65 72 20 75 6e 64 65 72 20 74 68 69 73 20 rver under this
2320: 6b 65 79 0a 3b 3b 3b 20 09 20 20 20 20 28 73 65 key.;;; . (se
2330: 72 76 6b 65 79 20 20 2e 20 73 29 20 20 3b 3b 20 rvkey . s) ;;
2340: 73 65 72 76 65 72 20 6b 65 79 20 2d 20 74 68 69 server key - thi
2350: 73 20 6e 65 65 64 73 20 74 6f 20 6d 61 74 63 68 s needs to match
2360: 20 61 74 20 73 65 72 76 65 72 20 65 6e 64 20 6f at server end o
2370: 72 20 72 65 6a 65 63 74 20 74 68 65 20 6d 73 67 r reject the msg
2380: 0a 3b 3b 3b 20 09 20 20 20 20 28 66 6f 72 6d 61 .;;; . (forma
2390: 74 20 20 20 2e 20 66 29 20 20 3b 3b 20 73 62 3d t . f) ;; sb=
23a0: 73 65 72 69 61 6c 69 7a 65 64 2d 62 61 73 65 36 serialized-base6
23b0: 34 2c 20 74 3d 74 65 78 74 2c 20 73 78 3d 73 65 4, t=text, sx=se
23c0: 78 70 72 2c 20 6a 3d 6a 73 6f 6e 0a 3b 3b 3b 20 xpr, j=json.;;;
23d0: 09 20 20 20 20 28 64 61 74 61 20 20 20 20 20 2e . (data .
23e0: 20 64 29 20 20 3b 3b 20 62 61 73 65 36 34 20 65 d) ;; base64 e
23f0: 6e 63 6f 64 65 64 20 73 6c 6c 6e 20 64 61 74 61 ncoded slln data
2400: 0a 3b 3b 3b 20 09 20 20 20 20 29 29 29 0a 3b 3b .;;; . ))).;;
2410: 3b 20 0a 3b 3b 3b 20 3b 3b 20 77 6f 72 6b 20 69 ; .;;; ;; work i
2420: 74 65 6d 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 tem.;;; ;;.;;; (
2430: 64 65 66 73 74 72 75 63 74 20 77 69 74 65 6d 0a defstruct witem.
2440: 3b 3b 3b 20 20 20 28 72 68 6f 73 74 20 23 66 29 ;;; (rhost #f)
2450: 20 20 20 3b 3b 20 72 65 74 75 72 6e 20 68 6f 73 ;; return hos
2460: 74 0a 3b 3b 3b 20 20 20 28 72 69 70 61 64 64 72 t.;;; (ripaddr
2470: 20 23 66 29 20 3b 3b 20 72 65 74 75 72 6e 20 69 #f) ;; return i
2480: 70 61 64 64 72 0a 3b 3b 3b 20 20 20 28 72 70 6f paddr.;;; (rpo
2490: 72 74 20 23 66 29 20 20 20 3b 3b 20 72 65 74 75 rt #f) ;; retu
24a0: 72 6e 20 70 6f 72 74 0a 3b 3b 3b 20 20 20 28 73 rn port.;;; (s
24b0: 65 72 76 6b 65 79 20 23 66 29 20 3b 3b 20 74 68 ervkey #f) ;; th
24c0: 65 20 70 61 63 6b 65 74 20 72 65 70 72 65 73 65 e packet represe
24d0: 6e 74 69 6e 67 20 74 68 65 20 63 6c 69 65 6e 74 nting the client
24e0: 20 6f 66 20 74 68 69 73 20 77 6f 72 6b 69 74 65 of this workite
24f0: 6d 2c 20 75 73 65 64 20 62 79 20 66 69 6e 61 6c m, used by final
2500: 20 73 65 6e 64 2d 6d 65 73 73 61 67 65 0a 3b 3b send-message.;;
2510: 3b 20 20 20 28 72 64 61 74 20 20 23 66 29 20 20 ; (rdat #f)
2520: 20 3b 3b 20 74 68 65 20 72 65 71 75 65 73 74 20 ;; the request
2530: 2d 20 75 73 75 61 6c 6c 79 20 61 6e 20 73 71 6c - usually an sql
2540: 20 71 75 65 72 79 2c 20 74 79 70 65 20 69 73 20 query, type is
2550: 72 64 61 74 0a 3b 3b 3b 20 20 20 28 61 63 74 69 rdat.;;; (acti
2560: 6f 6e 20 23 66 29 20 20 3b 3b 20 74 68 65 20 61 on #f) ;; the a
2570: 63 74 69 6f 6e 3a 20 69 6d 6d 65 64 69 61 74 65 ction: immediate
2580: 2c 20 64 62 77 72 69 74 65 2c 20 64 62 72 65 61 , dbwrite, dbrea
2590: 64 2c 6f 73 6c 6f 6e 67 2c 20 6f 73 73 68 6f 72 d,oslong, osshor
25a0: 74 0a 3b 3b 3b 20 20 20 28 63 6f 6f 6b 69 65 20 t.;;; (cookie
25b0: 23 66 29 20 20 3b 3b 20 63 6f 6f 6b 69 65 20 69 #f) ;; cookie i
25c0: 64 20 66 6f 72 20 72 65 73 70 6f 6e 73 65 0a 3b d for response.;
25d0: 3b 3b 20 20 20 28 64 61 74 61 20 20 20 23 66 29 ;; (data #f)
25e0: 20 20 3b 3b 20 74 68 65 20 64 61 74 61 20 70 61 ;; the data pa
25f0: 79 6c 6f 61 64 2c 20 69 2e 65 2e 20 70 61 72 61 yload, i.e. para
2600: 6d 65 74 65 72 73 0a 3b 3b 3b 20 20 20 28 72 65 meters.;;; (re
2610: 73 75 6c 74 20 23 66 29 20 20 3b 3b 20 74 68 65 sult #f) ;; the
2620: 20 72 65 73 75 6c 74 20 66 72 6f 6d 20 70 72 6f result from pro
2630: 63 65 73 73 69 6e 67 20 74 68 65 20 64 61 74 61 cessing the data
2640: 0a 3b 3b 3b 20 20 20 28 63 61 6c 6c 65 72 20 23 .;;; (caller #
2650: 66 29 29 20 3b 3b 20 74 68 65 20 63 61 6c 6c 69 f)) ;; the calli
2660: 6e 67 20 70 65 65 72 20 61 63 63 6f 72 64 69 6e ng peer accordin
2670: 67 20 74 6f 20 72 70 63 20 69 74 73 65 6c 66 0a g to rpc itself.
2680: 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 ;;; .;;; (define
2690: 20 28 74 72 69 6d 2d 70 6b 74 69 64 20 70 6b 74 (trim-pktid pkt
26a0: 69 64 29 0a 3b 3b 3b 20 20 20 28 69 66 20 28 73 id).;;; (if (s
26b0: 74 72 69 6e 67 3f 20 70 6b 74 69 64 29 0a 3b 3b tring? pktid).;;
26c0: 3b 20 20 20 20 20 20 20 28 73 75 62 73 74 72 69 ; (substri
26d0: 6e 67 20 70 6b 74 69 64 20 30 20 34 29 0a 3b 3b ng pktid 0 4).;;
26e0: 3b 20 20 20 20 20 20 20 22 6e 6f 70 6b 74 22 29 ; "nopkt")
26f0: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 ).;;; .;;; (defi
2700: 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 ne (any->number
2710: 6e 75 6d 29 0a 3b 3b 3b 20 20 20 28 63 6f 6e 64 num).;;; (cond
2720: 0a 3b 3b 3b 20 20 20 20 28 28 6e 75 6d 62 65 72 .;;; ((number
2730: 3f 20 6e 75 6d 29 20 6e 75 6d 29 0a 3b 3b 3b 20 ? num) num).;;;
2740: 20 20 20 28 28 73 74 72 69 6e 67 3f 20 6e 75 6d ((string? num
2750: 29 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 ) (string->numbe
2760: 72 20 6e 75 6d 29 29 0a 3b 3b 3b 20 20 20 20 28 r num)).;;; (
2770: 65 6c 73 65 20 6e 75 6d 29 29 29 0a 3b 3b 3b 20 else num))).;;;
2780: 0a 3b 3b 3b 20 28 75 73 65 20 74 72 61 63 65 29 .;;; (use trace)
2790: 0a 3b 3b 3b 20 28 74 72 61 63 65 2d 63 61 6c 6c .;;; (trace-call
27a0: 2d 73 69 74 65 73 20 23 74 29 0a 3b 3b 3b 20 0a -sites #t).;;; .
27b0: 3b 3b 3b 20 3b 3b 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 3d 3d 3d 3d ================
27e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b ============.;;;
2800: 20 3b 3b 20 44 20 41 20 54 20 41 20 42 20 41 20 ;; D A T A B A
2810: 53 20 45 20 20 20 48 20 41 20 4e 20 44 20 4c 20 S E H A N D L
2820: 49 20 4e 20 47 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d I N G .;;; ;;===
2830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2870: 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 ===.;;; .;;; ;;
2880: 6c 6f 6f 6b 20 69 6e 20 64 62 68 61 6e 64 6c 65 look in dbhandle
2890: 73 20 66 6f 72 20 61 20 64 62 2c 20 72 65 74 75 s for a db, retu
28a0: 72 6e 20 69 74 2c 20 65 6c 73 65 20 72 65 74 75 rn it, else retu
28b0: 72 6e 20 23 66 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b rn #f.;;; ;;.;;;
28c0: 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 62 (define (get-db
28d0: 68 20 61 63 66 67 20 66 6e 61 6d 65 29 0a 3b 3b h acfg fname).;;
28e0: 3b 20 20 20 28 6c 65 74 20 28 28 64 62 68 2d 6c ; (let ((dbh-l
28f0: 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 st (hash-table-r
2900: 65 66 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 ef/default (area
2910: 2d 64 62 68 61 6e 64 6c 65 73 20 61 63 66 67 29 -dbhandles acfg)
2920: 20 66 6e 61 6d 65 20 27 28 29 29 29 29 0a 3b 3b fname '()))).;;
2930: 3b 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ; (if (null?
2940: 20 64 62 68 2d 6c 73 74 29 0a 3b 3b 3b 20 09 28 dbh-lst).;;; .(
2950: 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 3b 3b 20 begin.;;; . ;;
2960: 28 70 72 69 6e 74 20 22 6f 70 65 6e 69 6e 67 20 (print "opening
2970: 64 62 20 66 6f 72 20 22 20 66 6e 61 6d 65 29 0a db for " fname).
2980: 3b 3b 3b 20 09 20 20 28 6f 70 65 6e 2d 64 62 20 ;;; . (open-db
2990: 61 63 66 67 20 66 6e 61 6d 65 29 29 20 3b 3b 20 acfg fname)) ;;
29a0: 4e 6f 74 65 20 74 68 61 74 20 74 68 65 20 68 61 Note that the ha
29b0: 6e 64 6c 65 73 20 67 65 74 20 70 75 74 20 62 61 ndles get put ba
29c0: 63 6b 20 69 6e 20 74 68 65 20 71 75 65 75 65 20 ck in the queue
29d0: 69 6e 20 74 68 65 20 73 61 76 65 2d 64 62 68 20 in the save-dbh
29e0: 63 61 6c 6c 73 0a 3b 3b 3b 20 09 28 6c 65 74 20 calls.;;; .(let
29f0: 28 28 72 65 6d 2d 6c 73 74 20 28 63 64 72 20 64 ((rem-lst (cdr d
2a00: 62 68 2d 6c 73 74 29 29 29 0a 3b 3b 3b 20 09 20 bh-lst))).;;; .
2a10: 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 65 2d 75 ;; (print "re-u
2a20: 73 69 6e 67 20 73 61 76 65 64 20 63 6f 6e 6e 65 sing saved conne
2a30: 63 74 69 6f 6e 20 66 6f 72 20 22 20 66 6e 61 6d ction for " fnam
2a40: 65 29 0a 3b 3b 3b 20 09 20 20 28 68 61 73 68 2d e).;;; . (hash-
2a50: 74 61 62 6c 65 2d 73 65 74 21 20 28 61 72 65 61 table-set! (area
2a60: 2d 64 62 68 61 6e 64 6c 65 73 20 61 63 66 67 29 -dbhandles acfg)
2a70: 20 66 6e 61 6d 65 20 72 65 6d 2d 6c 73 74 29 0a fname rem-lst).
2a80: 3b 3b 3b 20 09 20 20 28 63 61 72 20 64 62 68 2d ;;; . (car dbh-
2a90: 6c 73 74 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b lst))))).;;; .;;
2aa0: 3b 20 28 64 65 66 69 6e 65 20 28 73 61 76 65 2d ; (define (save-
2ab0: 64 62 68 20 61 63 66 67 20 66 6e 61 6d 65 20 64 dbh acfg fname d
2ac0: 62 64 61 74 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b bdat).;;; ;;
2ad0: 20 28 70 72 69 6e 74 20 22 73 61 76 69 6e 67 20 (print "saving
2ae0: 64 62 68 20 66 6f 72 20 22 20 66 6e 61 6d 65 29 dbh for " fname)
2af0: 0a 3b 3b 3b 20 20 20 20 20 28 68 61 73 68 2d 74 .;;; (hash-t
2b00: 61 62 6c 65 2d 73 65 74 21 20 28 61 72 65 61 2d able-set! (area-
2b10: 64 62 68 61 6e 64 6c 65 73 20 61 63 66 67 29 20 dbhandles acfg)
2b20: 66 6e 61 6d 65 20 28 63 6f 6e 73 20 64 62 64 61 fname (cons dbda
2b30: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
2b40: 66 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d f/default (area-
2b50: 64 62 68 61 6e 64 6c 65 73 20 61 63 66 67 29 20 dbhandles acfg)
2b60: 66 6e 61 6d 65 20 27 28 29 29 29 29 29 0a 3b 3b fname '())))).;;
2b70: 3b 20 0a 3b 3b 3b 20 3b 3b 20 6f 70 65 6e 20 74 ; .;;; ;; open t
2b80: 68 65 20 64 61 74 61 62 61 73 65 2c 20 69 66 20 he database, if
2b90: 6e 65 76 65 72 20 62 65 66 6f 72 65 20 6f 70 65 never before ope
2ba0: 6e 65 64 20 69 6e 69 74 20 69 74 2e 20 70 75 74 ned init it. put
2bb0: 20 74 68 65 20 68 61 6e 64 6c 65 20 69 6e 20 74 the handle in t
2bc0: 68 65 0a 3b 3b 3b 20 3b 3b 20 6f 70 65 6e 20 64 he.;;; ;; open d
2bd0: 62 27 73 20 68 61 73 68 20 74 61 62 6c 65 0a 3b b's hash table.;
2be0: 3b 3b 20 3b 3b 20 72 65 74 75 72 6e 73 3a 20 74 ;; ;; returns: t
2bf0: 68 65 20 64 62 64 61 74 0a 3b 3b 3b 20 3b 3b 0a he dbdat.;;; ;;.
2c00: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 6f 70 65 ;;; (define (ope
2c10: 6e 2d 64 62 20 61 63 66 67 20 66 6e 61 6d 65 29 n-db acfg fname)
2c20: 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 66 .;;; (let* ((f
2c30: 75 6c 6c 6e 61 6d 65 20 20 20 20 20 28 63 6f 6e ullname (con
2c40: 63 20 28 61 72 65 61 2d 64 62 64 69 72 20 61 63 c (area-dbdir ac
2c50: 66 67 29 20 22 2f 22 20 66 6e 61 6d 65 29 29 0a fg) "/" fname)).
2c60: 3b 3b 3b 20 09 20 28 65 78 69 73 74 73 20 20 20 ;;; . (exists
2c70: 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (file-exists
2c80: 3f 20 66 75 6c 6c 6e 61 6d 65 29 29 0a 3b 3b 3b ? fullname)).;;;
2c90: 20 09 20 28 77 72 69 74 65 2d 61 63 63 65 73 73 . (write-access
2ca0: 20 28 69 66 20 65 78 69 73 74 73 0a 3b 3b 3b 20 (if exists.;;;
2cb0: 09 09 09 20 20 20 28 66 69 6c 65 2d 77 72 69 74 ... (file-writ
2cc0: 65 2d 61 63 63 65 73 73 3f 20 66 75 6c 6c 6e 61 e-access? fullna
2cd0: 6d 65 29 0a 3b 3b 3b 20 09 09 09 20 20 20 28 66 me).;;; ... (f
2ce0: 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 ile-write-access
2cf0: 3f 20 28 61 72 65 61 2d 64 62 64 69 72 20 61 63 ? (area-dbdir ac
2d00: 66 67 29 29 29 29 0a 3b 3b 3b 20 09 20 28 64 62 fg)))).;;; . (db
2d10: 20 20 20 20 20 20 20 20 20 20 20 28 73 71 6c 69 (sqli
2d20: 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 te3:open-databas
2d30: 65 20 66 75 6c 6c 6e 61 6d 65 29 29 0a 3b 3b 3b e fullname)).;;;
2d40: 20 09 20 28 68 61 6e 64 6c 65 72 20 20 20 20 20 . (handler
2d50: 20 28 73 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 (sqlite3:make-b
2d60: 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 33 36 30 usy-timeout 1360
2d70: 30 30 29 29 0a 3b 3b 3b 20 09 20 29 0a 3b 3b 3b 00)).;;; . ).;;;
2d80: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 73 65 (sqlite3:se
2d90: 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 t-busy-handler!
2da0: 64 62 20 68 61 6e 64 6c 65 72 29 0a 3b 3b 3b 20 db handler).;;;
2db0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 (sqlite3:exe
2dc0: 63 75 74 65 20 64 62 20 22 50 52 41 47 4d 41 20 cute db "PRAGMA
2dd0: 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d 20 30 3b synchronous = 0;
2de0: 22 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 28 ").;;; (if (
2df0: 6e 6f 74 20 65 78 69 73 74 73 29 20 3b 3b 20 6e not exists) ;; n
2e00: 65 65 64 20 74 6f 20 69 6e 69 74 20 74 68 65 20 eed to init the
2e10: 64 62 0a 3b 3b 3b 20 09 28 69 66 20 77 72 69 74 db.;;; .(if writ
2e20: 65 2d 61 63 63 65 73 73 0a 3b 3b 3b 20 09 20 20 e-access.;;; .
2e30: 20 20 28 6c 65 74 20 28 28 69 73 71 6c 20 28 67 (let ((isql (g
2e40: 65 74 2d 72 73 71 6c 20 61 63 66 67 20 27 64 62 et-rsql acfg 'db
2e50: 69 6e 69 74 73 71 6c 29 29 29 20 3b 3b 20 67 65 initsql))) ;; ge
2e60: 74 20 74 68 65 20 69 6e 69 74 20 73 71 6c 20 73 t the init sql s
2e70: 74 61 74 65 6d 65 6e 74 73 0a 3b 3b 3b 20 09 20 tatements.;;; .
2e80: 20 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 ;; (sqlite3
2e90: 3a 77 69 74 68 2d 74 72 61 6e 73 61 63 74 69 6f :with-transactio
2ea0: 6e 0a 3b 3b 3b 20 09 20 20 20 20 20 20 3b 3b 20 n.;;; . ;;
2eb0: 20 64 62 0a 3b 3b 3b 20 09 20 20 20 20 20 20 3b db.;;; . ;
2ec0: 3b 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b ; (lambda ().;;
2ed0: 3b 20 09 09 20 28 69 66 20 69 73 71 6c 0a 3b 3b ; .. (if isql.;;
2ee0: 3b 20 09 09 20 20 20 20 20 28 66 6f 72 2d 65 61 ; .. (for-ea
2ef0: 63 68 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 28 ch.;;; .. (
2f00: 6c 61 6d 62 64 61 20 28 73 71 6c 29 0a 3b 3b 3b lambda (sql).;;;
2f10: 20 09 09 09 28 73 71 6c 69 74 65 33 3a 65 78 65 ...(sqlite3:exe
2f20: 63 75 74 65 20 64 62 20 73 71 6c 29 29 0a 3b 3b cute db sql)).;;
2f30: 3b 20 09 09 20 20 20 20 20 20 69 73 71 6c 29 29 ; .. isql))
2f40: 29 0a 3b 3b 3b 20 09 20 20 20 20 28 70 72 69 6e ).;;; . (prin
2f50: 74 20 22 45 52 52 4f 52 3a 20 6e 6f 20 77 72 69 t "ERROR: no wri
2f60: 74 65 20 61 63 63 65 73 73 20 74 6f 20 22 20 28 te access to " (
2f70: 61 72 65 61 2d 64 62 64 69 72 20 61 63 66 67 29 area-dbdir acfg)
2f80: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 6d 61 6b ))).;;; (mak
2f90: 65 2d 64 62 64 61 74 20 64 62 68 3a 20 64 62 20 e-dbdat dbh: db
2fa0: 66 6e 61 6d 65 3a 20 66 6e 61 6d 65 20 77 72 69 fname: fname wri
2fb0: 74 65 2d 61 63 63 65 73 73 3a 20 77 72 69 74 65 te-access: write
2fc0: 2d 61 63 63 65 73 73 29 29 29 0a 3b 3b 3b 20 0a -access))).;;; .
2fd0: 3b 3b 3b 20 3b 3b 20 54 68 69 73 20 69 73 20 61 ;;; ;; This is a
2fe0: 20 6c 6f 77 2d 6c 65 76 65 6c 20 63 6f 6d 6d 61 low-level comma
2ff0: 6e 64 20 74 6f 20 72 65 74 72 69 65 76 65 20 6f nd to retrieve o
3000: 72 20 74 6f 20 70 72 65 70 61 72 65 2c 20 73 61 r to prepare, sa
3010: 76 65 20 61 6e 64 20 72 65 74 75 72 6e 20 61 20 ve and return a
3020: 70 72 65 70 61 72 65 64 20 73 74 61 74 6d 65 6e prepared statmen
3030: 74 0a 3b 3b 3b 20 3b 3b 20 79 6f 75 20 6d 75 73 t.;;; ;; you mus
3040: 74 20 65 78 74 72 61 63 74 20 74 68 65 20 64 62 t extract the db
3050: 20 68 61 6e 64 6c 65 0a 3b 3b 3b 20 3b 3b 0a 3b handle.;;; ;;.;
3060: 3b 3b 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d ;; (define (get-
3070: 73 74 68 20 64 62 20 63 61 63 68 65 20 73 74 6d sth db cache stm
3080: 74 29 0a 3b 3b 3b 20 20 20 28 69 66 20 28 68 61 t).;;; (if (ha
3090: 73 68 2d 74 61 62 6c 65 2d 65 78 69 73 74 73 3f sh-table-exists?
30a0: 20 63 61 63 68 65 20 73 74 6d 74 29 0a 3b 3b 3b cache stmt).;;;
30b0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b (begin.;;
30c0: 3b 20 09 3b 3b 20 28 70 72 69 6e 74 20 22 52 65 ; .;; (print "Re
30d0: 75 73 69 6e 67 20 63 61 63 68 65 64 20 73 74 6d using cached stm
30e0: 74 20 66 6f 72 20 22 20 73 74 6d 74 29 0a 3b 3b t for " stmt).;;
30f0: 3b 20 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ; .(hash-table-r
3100: 65 66 2f 64 65 66 61 75 6c 74 20 63 61 63 68 65 ef/default cache
3110: 20 73 74 6d 74 20 23 66 29 29 0a 3b 3b 3b 20 20 stmt #f)).;;;
3120: 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 68 20 (let ((sth
3130: 28 73 71 6c 69 74 65 33 3a 70 72 65 70 61 72 65 (sqlite3:prepare
3140: 20 64 62 20 73 74 6d 74 29 29 29 0a 3b 3b 3b 20 db stmt))).;;;
3150: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
3160: 21 20 63 61 63 68 65 20 73 74 6d 74 20 73 74 68 ! cache stmt sth
3170: 29 0a 3b 3b 3b 20 09 3b 3b 20 28 70 72 69 6e 74 ).;;; .;; (print
3180: 20 22 70 72 65 70 61 72 65 64 20 73 74 6d 74 20 "prepared stmt
3190: 66 6f 72 20 22 20 73 74 6d 74 29 0a 3b 3b 3b 20 for " stmt).;;;
31a0: 09 73 74 68 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b .sth))).;;; .;;;
31b0: 20 3b 3b 20 61 20 6c 69 74 74 6c 65 20 6d 6f 72 ;; a little mor
31c0: 65 20 65 78 70 65 6e 73 69 76 65 20 62 75 74 20 e expensive but
31d0: 64 6f 65 73 20 61 6c 6c 20 74 68 65 20 74 65 64 does all the ted
31e0: 69 6f 75 73 20 64 65 66 65 72 65 6e 63 69 6e 67 ious deferencing
31f0: 20 2d 20 6f 6e 6c 79 20 75 73 65 20 69 66 20 79 - only use if y
3200: 6f 75 20 64 6f 6e 27 74 20 61 6c 72 65 61 64 79 ou don't already
3210: 0a 3b 3b 3b 20 3b 3b 20 68 61 76 65 20 64 62 64 .;;; ;; have dbd
3220: 61 74 20 61 6e 64 20 64 62 20 73 69 74 74 69 6e at and db sittin
3230: 67 20 61 72 6f 75 6e 64 0a 3b 3b 3b 20 3b 3b 0a g around.;;; ;;.
3240: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 66 75 6c ;;; (define (ful
3250: 6c 2d 67 65 74 2d 73 74 68 20 61 63 66 67 20 66 l-get-sth acfg f
3260: 6e 61 6d 65 20 73 74 6d 74 29 0a 3b 3b 3b 20 20 name stmt).;;;
3270: 20 28 6c 65 74 2a 20 28 28 64 62 64 61 74 20 20 (let* ((dbdat
3280: 28 67 65 74 2d 64 62 68 20 61 63 66 67 20 66 6e (get-dbh acfg fn
3290: 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 28 64 62 20 ame)).;;; . (db
32a0: 20 20 20 20 28 64 62 64 61 74 2d 64 62 68 20 64 (dbdat-dbh d
32b0: 62 64 61 74 29 29 0a 3b 3b 3b 20 09 20 28 73 74 bdat)).;;; . (st
32c0: 68 73 20 20 20 28 64 62 64 61 74 2d 73 74 68 73 hs (dbdat-sths
32d0: 20 64 62 64 61 74 29 29 29 0a 3b 3b 3b 20 20 20 dbdat))).;;;
32e0: 20 20 28 67 65 74 2d 73 74 68 20 64 62 20 73 74 (get-sth db st
32f0: 68 73 20 73 74 6d 74 29 29 29 0a 3b 3b 3b 20 0a hs stmt))).;;; .
3300: 3b 3b 3b 20 3b 3b 20 77 72 69 74 65 20 74 6f 20 ;;; ;; write to
3310: 61 20 64 62 0a 3b 3b 3b 20 3b 3b 20 61 63 66 67 a db.;;; ;; acfg
3320: 3a 20 61 72 65 61 20 64 61 74 61 0a 3b 3b 3b 20 : area data.;;;
3330: 3b 3b 20 72 64 61 74 3a 20 72 65 71 75 65 73 74 ;; rdat: request
3340: 20 64 61 74 61 0a 3b 3b 3b 20 3b 3b 20 68 64 61 data.;;; ;; hda
3350: 74 3a 20 28 68 6f 73 74 20 2e 20 70 6f 72 74 29 t: (host . port)
3360: 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 28 .;;; ;;.;;; ;; (
3370: 64 65 66 69 6e 65 20 28 64 62 77 72 69 74 65 20 define (dbwrite
3380: 61 63 66 67 20 72 64 61 74 20 68 64 61 74 20 64 acfg rdat hdat d
3390: 61 74 61 2d 69 6e 29 0a 3b 3b 3b 20 3b 3b 20 20 ata-in).;;; ;;
33a0: 20 28 6c 65 74 2a 20 28 28 64 62 6e 61 6d 65 20 (let* ((dbname
33b0: 28 63 61 72 20 64 61 74 61 2d 69 6e 29 29 0a 3b (car data-in)).;
33c0: 3b 3b 20 3b 3b 20 09 20 28 64 62 64 61 74 20 20 ;; ;; . (dbdat
33d0: 28 67 65 74 2d 64 62 68 20 61 63 66 67 20 64 62 (get-dbh acfg db
33e0: 6e 61 6d 65 29 29 0a 3b 3b 3b 20 3b 3b 20 09 20 name)).;;; ;; .
33f0: 28 64 62 20 20 20 20 20 28 64 62 64 61 74 2d 64 (db (dbdat-d
3400: 62 68 20 64 62 64 61 74 29 29 0a 3b 3b 3b 20 3b bh dbdat)).;;; ;
3410: 3b 20 09 20 28 73 74 68 73 20 20 20 28 64 62 64 ; . (sths (dbd
3420: 61 74 2d 73 74 68 73 20 64 62 64 61 74 29 29 0a at-sths dbdat)).
3430: 3b 3b 3b 20 3b 3b 20 09 20 28 73 74 6d 74 20 20 ;;; ;; . (stmt
3440: 20 28 63 61 6c 6c 64 61 74 2d 6f 62 6a 20 72 64 (calldat-obj rd
3450: 61 74 29 29 0a 3b 3b 3b 20 3b 3b 20 09 20 28 73 at)).;;; ;; . (s
3460: 74 68 20 20 20 20 28 67 65 74 2d 73 74 68 20 64 th (get-sth d
3470: 62 20 73 74 68 73 20 73 74 6d 74 29 29 0a 3b 3b b sths stmt)).;;
3480: 3b 20 3b 3b 20 09 20 28 64 61 74 61 20 20 20 28 ; ;; . (data (
3490: 63 64 72 20 64 61 74 61 2d 69 6e 29 29 29 0a 3b cdr data-in))).;
34a0: 3b 3b 20 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 ;; ;; (print
34b0: 20 22 64 62 6e 61 6d 65 3a 20 22 20 64 62 6e 61 "dbname: " dbna
34c0: 6d 65 20 22 20 61 63 66 67 3a 20 22 20 61 63 66 me " acfg: " acf
34d0: 67 20 22 20 72 64 61 74 3a 20 22 20 28 63 61 6c g " rdat: " (cal
34e0: 6c 64 61 74 2d 3e 61 6c 69 73 74 20 72 64 61 74 ldat->alist rdat
34f0: 29 20 22 20 68 64 61 74 3a 20 22 20 68 64 61 74 ) " hdat: " hdat
3500: 20 22 20 64 61 74 61 3a 20 22 20 64 61 74 61 29 " data: " data)
3510: 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 28 70 72 69 .;;; ;; (pri
3520: 6e 74 20 22 64 62 64 61 74 3a 20 22 20 28 64 62 nt "dbdat: " (db
3530: 64 61 74 2d 3e 61 6c 69 73 74 20 64 62 64 61 74 dat->alist dbdat
3540: 29 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 28 61 )).;;; ;; (a
3550: 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 pply sqlite3:exe
3560: 63 75 74 65 20 73 74 68 20 64 61 74 61 29 0a 3b cute sth data).;
3570: 3b 3b 20 3b 3b 20 20 20 20 20 28 73 61 76 65 2d ;; ;; (save-
3580: 64 62 68 20 61 63 66 67 20 64 62 6e 61 6d 65 20 dbh acfg dbname
3590: 64 62 64 61 74 29 0a 3b 3b 3b 20 3b 3b 20 20 20 dbdat).;;; ;;
35a0: 20 20 23 74 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 #t.;;; ;;
35b0: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 )).;;; .;;; (def
35c0: 69 6e 65 20 28 66 69 6e 61 6c 69 7a 65 2d 61 6c ine (finalize-al
35d0: 6c 2d 64 62 2d 68 61 6e 64 6c 65 73 20 61 63 66 l-db-handles acf
35e0: 67 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 g).;;; (let* (
35f0: 28 64 62 68 61 6e 64 6c 65 73 20 28 61 72 65 61 (dbhandles (area
3600: 2d 64 62 68 61 6e 64 6c 65 73 20 61 63 66 67 29 -dbhandles acfg)
3610: 29 20 20 3b 3b 20 64 62 68 61 6e 64 6c 65 73 20 ) ;; dbhandles
3620: 69 73 20 68 61 73 68 20 6f 66 20 66 6e 61 6d 65 is hash of fname
3630: 20 3d 3d 3e 20 64 62 64 61 74 0a 3b 3b 3b 20 09 ==> dbdat.;;; .
3640: 20 28 6e 75 6d 20 20 20 20 20 20 20 30 29 29 0a (num 0)).
3650: 3b 3b 3b 20 20 20 20 20 28 66 6f 72 2d 65 61 63 ;;; (for-eac
3660: 68 0a 3b 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 h.;;; (lamb
3670: 64 61 20 28 61 72 65 61 2d 6e 61 6d 65 29 0a 3b da (area-name).;
3680: 3b 3b 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 ;; (print
3690: 20 22 43 6c 6f 73 69 6e 67 20 68 61 6e 64 6c 65 "Closing handle
36a0: 73 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d s for " area-nam
36b0: 65 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 6c e).;;; (l
36c0: 65 74 20 28 28 64 62 64 61 74 73 20 28 68 61 73 et ((dbdats (has
36d0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
36e0: 75 6c 74 20 64 62 68 61 6e 64 6c 65 73 20 61 72 ult dbhandles ar
36f0: 65 61 2d 6e 61 6d 65 20 27 28 29 29 29 29 0a 3b ea-name '()))).;
3700: 3b 3b 20 09 20 28 66 6f 72 2d 65 61 63 68 0a 3b ;; . (for-each.;
3710: 3b 3b 20 09 20 20 28 6c 61 6d 62 64 61 20 28 64 ;; . (lambda (d
3720: 62 64 61 74 29 0a 3b 3b 3b 20 09 20 20 20 20 3b bdat).;;; . ;
3730: 3b 20 66 69 72 73 74 20 63 6c 6f 73 65 20 61 6c ; first close al
3740: 6c 20 73 74 61 74 65 6d 65 6e 74 20 68 61 6e 64 l statement hand
3750: 6c 65 73 0a 3b 3b 3b 20 09 20 20 20 20 28 66 6f les.;;; . (fo
3760: 72 2d 65 61 63 68 0a 3b 3b 3b 20 09 20 20 20 20 r-each.;;; .
3770: 20 28 6c 61 6d 62 64 61 20 28 73 74 68 29 0a 3b (lambda (sth).;
3780: 3b 3b 20 09 20 20 20 20 20 20 20 28 73 71 6c 69 ;; . (sqli
3790: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 73 74 te3:finalize! st
37a0: 68 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 h).;;; . (
37b0: 73 65 74 21 20 6e 75 6d 20 28 2b 20 6e 75 6d 20 set! num (+ num
37c0: 31 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 28 1))).;;; . (
37d0: 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 hash-table-value
37e0: 73 20 28 64 62 64 61 74 2d 73 74 68 73 20 64 62 s (dbdat-sths db
37f0: 64 61 74 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 dat))).;;; .
3800: 3b 3b 20 6e 6f 77 20 63 6c 6f 73 65 20 74 68 65 ;; now close the
3810: 20 64 62 68 0a 3b 3b 3b 20 09 20 20 20 20 28 73 dbh.;;; . (s
3820: 65 74 21 20 6e 75 6d 20 28 2b 20 6e 75 6d 20 31 et! num (+ num 1
3830: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 73 71 6c )).;;; . (sql
3840: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 28 ite3:finalize! (
3850: 64 62 64 61 74 2d 64 62 68 20 64 62 64 61 74 29 dbdat-dbh dbdat)
3860: 29 29 0a 3b 3b 3b 20 09 20 20 64 62 64 61 74 73 )).;;; . dbdats
3870: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 28 68 61 ))).;;; (ha
3880: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 64 62 sh-table-keys db
3890: 68 61 6e 64 6c 65 73 29 29 0a 3b 3b 3b 20 20 20 handles)).;;;
38a0: 20 20 28 70 72 69 6e 74 20 22 46 49 4e 41 4c 49 (print "FINALI
38b0: 5a 45 44 20 22 20 6e 75 6d 20 22 20 64 62 68 61 ZED " num " dbha
38c0: 6e 64 6c 65 73 22 29 29 29 0a 3b 3b 3b 20 0a 3b ndles"))).;;; .;
38d0: 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;; ;;===========
38e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
38f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 ===========.;;;
3920: 3b 3b 20 57 20 4f 20 52 20 4b 20 20 20 51 20 55 ;; W O R K Q U
3930: 20 45 20 55 20 45 20 20 20 48 20 41 20 4e 20 44 E U E H A N D
3940: 20 4c 20 49 20 4e 20 47 20 0a 3b 3b 3b 20 3b 3b L I N G .;;; ;;
3950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3990: 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 ======.;;; .;;;
39a0: 28 64 65 66 69 6e 65 20 28 72 65 67 69 73 74 65 (define (registe
39b0: 72 2d 64 62 2d 61 73 2d 6d 69 6e 65 20 61 63 66 r-db-as-mine acf
39c0: 67 20 64 62 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 g dbname).;;;
39d0: 28 6c 65 74 20 28 28 68 74 20 28 61 72 65 61 2d (let ((ht (area-
39e0: 64 62 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 dbs acfg))).;;;
39f0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 (if (not (ha
3a00: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
3a10: 61 75 6c 74 20 68 74 20 64 62 6e 61 6d 65 20 23 ault ht dbname #
3a20: 66 29 29 0a 3b 3b 3b 20 09 28 68 61 73 68 2d 74 f)).;;; .(hash-t
3a30: 61 62 6c 65 2d 73 65 74 21 20 68 74 20 64 62 6e able-set! ht dbn
3a40: 61 6d 65 20 28 72 61 6e 64 6f 6d 20 31 30 30 30 ame (random 1000
3a50: 30 29 29 29 29 29 0a 3b 3b 3b 20 09 0a 3b 3b 3b 0))))).;;; ..;;;
3a60: 20 28 64 65 66 69 6e 65 20 28 77 6f 72 6b 2d 71 (define (work-q
3a70: 75 65 75 65 2d 61 64 64 20 61 63 66 67 20 66 6e ueue-add acfg fn
3a80: 61 6d 65 20 77 69 74 65 6d 29 0a 3b 3b 3b 20 20 ame witem).;;;
3a90: 20 28 6c 65 74 2a 20 28 28 77 6f 72 6b 2d 71 75 (let* ((work-qu
3aa0: 65 75 65 2d 73 74 61 72 74 20 28 63 75 72 72 65 eue-start (curre
3ab0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
3ac0: 29 0a 3b 3b 3b 20 09 20 28 61 63 74 69 6f 6e 20 ).;;; . (action
3ad0: 20 20 20 20 20 20 20 20 20 20 28 77 69 74 65 6d (witem
3ae0: 2d 61 63 74 69 6f 6e 20 77 69 74 65 6d 29 29 20 -action witem))
3af0: 3b 3b 20 4e 42 20 74 68 65 20 61 63 74 69 6f 6e ;; NB the action
3b00: 20 69 73 20 74 68 65 20 69 6e 64 65 78 20 69 6e is the index in
3b10: 74 6f 20 74 68 65 20 72 64 61 74 20 61 63 74 69 to the rdat acti
3b20: 6f 6e 73 0a 3b 3b 3b 20 09 20 28 71 64 61 74 20 ons.;;; . (qdat
3b30: 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 (or
3b40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
3b50: 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d 77 71 default (area-wq
3b60: 75 65 75 65 73 20 61 63 66 67 29 20 66 6e 61 6d ueues acfg) fnam
3b70: 65 20 23 66 29 0a 3b 3b 3b 20 09 09 09 20 20 20 e #f).;;; ...
3b80: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 71 64 (let ((newqd
3b90: 61 74 20 28 6d 61 6b 65 2d 71 64 61 74 29 29 29 at (make-qdat)))
3ba0: 0a 3b 3b 3b 20 09 09 09 09 20 28 68 61 73 68 2d .;;; .... (hash-
3bb0: 74 61 62 6c 65 2d 73 65 74 21 20 28 61 72 65 61 table-set! (area
3bc0: 2d 77 71 75 65 75 65 73 20 61 63 66 67 29 20 66 -wqueues acfg) f
3bd0: 6e 61 6d 65 20 6e 65 77 71 64 61 74 29 0a 3b 3b name newqdat).;;
3be0: 3b 20 09 09 09 09 20 6e 65 77 71 64 61 74 29 29 ; .... newqdat))
3bf0: 29 0a 3b 3b 3b 20 09 20 28 72 64 61 74 20 20 20 ).;;; . (rdat
3c00: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
3c10: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
3c20: 74 20 28 61 72 65 61 2d 72 74 61 62 6c 65 20 61 t (area-rtable a
3c30: 63 66 67 29 20 61 63 74 69 6f 6e 20 23 66 29 29 cfg) action #f))
3c40: 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 72 64 ).;;; (if rd
3c50: 61 74 0a 3b 3b 3b 20 09 28 71 75 65 75 65 2d 61 at.;;; .(queue-a
3c60: 64 64 21 0a 3b 3b 3b 20 09 20 28 63 61 73 65 20 dd!.;;; . (case
3c70: 28 63 61 6c 6c 64 61 74 2d 63 74 79 70 65 20 72 (calldat-ctype r
3c80: 64 61 74 29 0a 3b 3b 3b 20 09 20 20 20 28 28 64 dat).;;; . ((d
3c90: 62 77 72 69 74 65 29 20 20 20 28 72 65 67 69 73 bwrite) (regis
3ca0: 74 65 72 2d 64 62 2d 61 73 2d 6d 69 6e 65 20 61 ter-db-as-mine a
3cb0: 63 66 67 20 66 6e 61 6d 65 29 28 71 64 61 74 2d cfg fname)(qdat-
3cc0: 77 72 69 74 65 71 20 71 64 61 74 29 29 0a 3b 3b writeq qdat)).;;
3cd0: 3b 20 09 20 20 20 28 28 64 62 72 65 61 64 29 20 ; . ((dbread)
3ce0: 20 20 20 28 72 65 67 69 73 74 65 72 2d 64 62 2d (register-db-
3cf0: 61 73 2d 6d 69 6e 65 20 61 63 66 67 20 66 6e 61 as-mine acfg fna
3d00: 6d 65 29 28 71 64 61 74 2d 72 65 61 64 71 20 20 me)(qdat-readq
3d10: 71 64 61 74 29 29 0a 3b 3b 3b 20 09 20 20 20 28 qdat)).;;; . (
3d20: 28 64 62 72 77 29 20 20 20 20 20 20 28 72 65 67 (dbrw) (reg
3d30: 69 73 74 65 72 2d 64 62 2d 61 73 2d 6d 69 6e 65 ister-db-as-mine
3d40: 20 61 63 66 67 20 66 6e 61 6d 65 29 28 71 64 61 acfg fname)(qda
3d50: 74 2d 72 77 71 20 20 20 20 71 64 61 74 29 29 0a t-rwq qdat)).
3d60: 3b 3b 3b 20 09 20 20 20 28 28 6f 73 6c 6f 6e 67 ;;; . ((oslong
3d70: 29 20 20 20 20 28 71 64 61 74 2d 6f 73 6c 6f 6e ) (qdat-oslon
3d80: 67 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 20 20 g qdat)).;;; .
3d90: 20 28 28 6f 73 73 68 6f 72 74 29 20 20 20 28 71 ((osshort) (q
3da0: 64 61 74 2d 6f 73 73 68 6f 72 74 20 71 64 61 74 dat-osshort qdat
3db0: 29 29 0a 3b 3b 3b 20 09 20 20 20 28 28 66 75 6c )).;;; . ((ful
3dc0: 6c 2d 70 69 6e 67 29 20 28 71 64 61 74 2d 6d 69 l-ping) (qdat-mi
3dd0: 73 63 20 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 sc qdat)).;;; .
3de0: 20 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 20 20 (else.;;; .
3df0: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
3e00: 20 6e 6f 20 71 75 65 75 65 20 66 6f 72 20 22 20 no queue for "
3e10: 61 63 74 69 6f 6e 20 22 2e 20 41 64 64 69 6e 67 action ". Adding
3e20: 20 74 6f 20 64 62 77 72 69 74 65 20 71 75 65 75 to dbwrite queu
3e30: 65 2e 22 29 0a 3b 3b 3b 20 09 20 20 20 20 28 71 e.").;;; . (q
3e40: 64 61 74 2d 77 72 69 74 65 71 20 71 64 61 74 29 dat-writeq qdat)
3e50: 29 29 0a 3b 3b 3b 20 09 20 77 69 74 65 6d 29 0a )).;;; . witem).
3e60: 3b 3b 3b 20 09 28 63 61 73 65 20 61 63 74 69 6f ;;; .(case actio
3e70: 6e 0a 3b 3b 3b 20 09 20 20 28 28 66 75 6c 6c 2d n.;;; . ((full-
3e80: 70 69 6e 67 29 28 71 64 61 74 2d 6d 69 73 63 20 ping)(qdat-misc
3e90: 71 64 61 74 29 29 0a 3b 3b 3b 20 09 20 20 28 65 qdat)).;;; . (e
3ea0: 6c 73 65 0a 3b 3b 3b 20 09 20 20 20 28 70 72 69 lse.;;; . (pri
3eb0: 6e 74 20 22 45 52 52 4f 52 3a 20 4e 6f 20 61 63 nt "ERROR: No ac
3ec0: 74 69 6f 6e 20 22 20 61 63 74 69 6f 6e 20 22 20 tion " action "
3ed0: 77 61 73 20 72 65 67 69 73 74 65 72 65 64 22 29 was registered")
3ee0: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 73 64 62 ))).;;; (sdb
3ef0: 67 3e 20 22 77 6f 72 6b 2d 71 75 65 75 65 2d 61 g> "work-queue-a
3f00: 64 64 22 20 22 71 75 65 75 65 2d 61 64 64 22 20 dd" "queue-add"
3f10: 77 6f 72 6b 2d 71 75 65 75 65 2d 73 74 61 72 74 work-queue-start
3f20: 20 23 66 20 23 66 29 0a 3b 3b 3b 20 20 20 20 20 #f #f).;;;
3f30: 23 74 29 29 20 3b 3b 20 66 6f 72 20 6e 6f 77 2c #t)) ;; for now,
3f40: 20 73 69 6d 70 6c 79 20 72 65 74 75 72 6e 20 23 simply return #
3f50: 74 20 74 6f 20 69 6e 64 69 63 61 74 65 20 72 65 t to indicate re
3f60: 71 75 65 73 74 20 67 6f 74 20 74 6f 20 74 68 65 quest got to the
3f70: 20 71 75 65 75 65 0a 3b 3b 3b 20 0a 3b 3b 3b 20 queue.;;; .;;;
3f80: 28 64 65 66 69 6e 65 20 28 64 6f 71 75 65 75 65 (define (doqueue
3f90: 20 61 63 66 67 20 71 20 66 6e 61 6d 65 20 64 62 acfg q fname db
3fa0: 64 61 74 20 64 62 68 29 0a 3b 3b 3b 20 20 20 3b dat dbh).;;; ;
3fb0: 3b 20 28 70 72 69 6e 74 20 22 64 6f 71 75 65 75 ; (print "doqueu
3fc0: 65 3a 20 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 e: " fname).;;;
3fd0: 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 2d (let* ((start-
3fe0: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 time (current-mi
3ff0: 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b lliseconds)).;;;
4000: 20 09 20 28 71 6c 65 6e 20 20 20 20 20 20 20 28 . (qlen (
4010: 71 75 65 75 65 2d 6c 65 6e 67 74 68 20 71 29 29 queue-length q))
4020: 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 28 3e ).;;; (if (>
4030: 20 71 6c 65 6e 20 31 29 0a 3b 3b 3b 20 09 28 70 qlen 1).;;; .(p
4040: 72 69 6e 74 20 22 50 72 6f 63 65 73 73 69 6e 67 rint "Processing
4050: 20 71 75 65 75 65 20 6f 66 20 6c 65 6e 67 74 68 queue of length
4060: 20 22 20 71 6c 65 6e 29 29 0a 3b 3b 3b 20 20 20 " qlen)).;;;
4070: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6f (let loop ((co
4080: 75 6e 74 20 20 20 20 20 20 30 29 0a 3b 3b 3b 20 unt 0).;;;
4090: 09 20 20 20 20 20 20 20 28 72 65 73 70 6f 6e 73 . (respons
40a0: 65 73 20 27 28 29 29 29 0a 3b 3b 3b 20 20 20 20 es '())).;;;
40b0: 20 20 20 28 6c 65 74 20 28 28 64 65 6c 74 61 20 (let ((delta
40c0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (- (current-mill
40d0: 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d iseconds) start-
40e0: 74 69 6d 65 29 29 29 0a 3b 3b 3b 20 09 28 69 66 time))).;;; .(if
40f0: 20 28 6f 72 20 28 71 75 65 75 65 2d 65 6d 70 74 (or (queue-empt
4100: 79 3f 20 71 29 0a 3b 3b 3b 20 09 09 28 3e 20 64 y? q).;;; ..(> d
4110: 65 6c 74 61 20 34 30 30 29 29 20 3b 3b 20 73 74 elta 400)) ;; st
4120: 6f 70 20 77 6f 72 6b 69 6e 67 20 6f 6e 20 74 68 op working on th
4130: 69 73 20 71 75 65 75 65 20 61 66 74 65 72 20 34 is queue after 4
4140: 30 30 6d 73 20 68 61 76 65 20 70 61 73 73 65 64 00ms have passed
4150: 0a 3b 3b 3b 20 09 20 20 20 20 28 6c 69 73 74 20 .;;; . (list
4160: 63 6f 75 6e 74 20 64 65 6c 74 61 20 72 65 73 70 count delta resp
4170: 6f 6e 73 65 73 29 20 3b 3b 20 72 65 74 75 72 6e onses) ;; return
4180: 20 63 6f 75 6e 74 2c 20 64 65 6c 74 61 20 61 6e count, delta an
4190: 64 20 72 65 73 70 6f 6e 73 65 73 20 6c 69 73 74 d responses list
41a0: 0a 3b 3b 3b 20 09 20 20 20 20 28 6c 65 74 2a 20 .;;; . (let*
41b0: 28 28 77 69 74 65 6d 20 20 28 71 75 65 75 65 2d ((witem (queue-
41c0: 72 65 6d 6f 76 65 21 20 71 29 29 0a 3b 3b 3b 20 remove! q)).;;;
41d0: 09 09 20 20 20 28 61 63 74 69 6f 6e 20 28 77 69 .. (action (wi
41e0: 74 65 6d 2d 61 63 74 69 6f 6e 20 77 69 74 65 6d tem-action witem
41f0: 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 72 64 61 )).;;; .. (rda
4200: 74 20 20 20 28 77 69 74 65 6d 2d 72 64 61 74 20 t (witem-rdat
4210: 20 20 77 69 74 65 6d 29 29 0a 3b 3b 3b 20 09 09 witem)).;;; ..
4220: 20 20 20 28 73 74 6d 74 20 20 20 28 63 61 6c 6c (stmt (call
4230: 64 61 74 2d 6f 62 6a 20 72 64 61 74 29 29 0a 3b dat-obj rdat)).;
4240: 3b 3b 20 09 09 20 20 20 28 73 74 68 20 20 20 20 ;; .. (sth
4250: 28 66 75 6c 6c 2d 67 65 74 2d 73 74 68 20 61 63 (full-get-sth ac
4260: 66 67 20 66 6e 61 6d 65 20 73 74 6d 74 29 29 0a fg fname stmt)).
4270: 3b 3b 3b 20 09 09 20 20 20 28 63 74 79 70 65 20 ;;; .. (ctype
4280: 20 28 63 61 6c 6c 64 61 74 2d 63 74 79 70 65 20 (calldat-ctype
4290: 72 64 61 74 29 29 0a 3b 3b 3b 20 09 09 20 20 20 rdat)).;;; ..
42a0: 28 64 61 74 61 20 20 20 28 77 69 74 65 6d 2d 64 (data (witem-d
42b0: 61 74 61 20 20 20 77 69 74 65 6d 29 29 0a 3b 3b ata witem)).;;
42c0: 3b 20 09 09 20 20 20 28 63 6f 6f 6b 69 65 20 28 ; .. (cookie (
42d0: 77 69 74 65 6d 2d 63 6f 6f 6b 69 65 20 77 69 74 witem-cookie wit
42e0: 65 6d 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 em))).;;; .
42f0: 20 3b 3b 20 64 6f 20 74 68 65 20 70 72 6f 63 65 ;; do the proce
4300: 73 73 69 6e 67 20 61 6e 64 20 73 61 76 65 20 74 ssing and save t
4310: 68 65 20 72 65 73 75 6c 74 20 69 6e 20 77 69 74 he result in wit
4320: 65 6d 2d 72 65 73 75 6c 74 0a 3b 3b 3b 20 09 20 em-result.;;; .
4330: 20 20 20 20 20 28 77 69 74 65 6d 2d 72 65 73 75 (witem-resu
4340: 6c 74 2d 73 65 74 21 0a 3b 3b 3b 20 09 20 20 20 lt-set!.;;; .
4350: 20 20 20 20 77 69 74 65 6d 0a 3b 3b 3b 20 09 20 witem.;;; .
4360: 20 20 20 20 20 20 28 63 61 73 65 20 63 74 79 70 (case ctyp
4370: 65 20 3b 3b 20 61 63 74 69 6f 6e 0a 3b 3b 3b 20 e ;; action.;;;
4380: 09 09 20 28 28 6e 6f 62 6c 6f 63 6b 77 72 69 74 .. ((noblockwrit
4390: 65 29 20 3b 3b 20 62 6c 69 6e 64 20 77 72 69 74 e) ;; blind writ
43a0: 65 2c 20 6e 6f 20 61 63 6b 20 6f 66 20 73 75 63 e, no ack of suc
43b0: 63 65 73 73 20 72 65 74 75 72 6e 65 64 0a 3b 3b cess returned.;;
43c0: 3b 20 09 09 20 20 28 61 70 70 6c 79 20 73 71 6c ; .. (apply sql
43d0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 73 74 68 ite3:execute sth
43e0: 20 64 61 74 61 29 0a 3b 3b 3b 20 09 09 20 20 28 data).;;; .. (
43f0: 73 71 6c 69 74 65 33 3a 6c 61 73 74 2d 69 6e 73 sqlite3:last-ins
4400: 65 72 74 2d 72 6f 77 69 64 20 64 62 68 29 29 0a ert-rowid dbh)).
4410: 3b 3b 3b 20 09 09 20 28 28 64 62 77 72 69 74 65 ;;; .. ((dbwrite
4420: 29 20 20 20 20 20 20 3b 3b 20 62 6c 6f 63 6b 69 ) ;; blocki
4430: 6e 67 20 77 72 69 74 65 20 20 20 0a 3b 3b 3b 20 ng write .;;;
4440: 09 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 .. (apply sqlit
4450: 65 33 3a 65 78 65 63 75 74 65 20 73 74 68 20 64 e3:execute sth d
4460: 61 74 61 29 0a 3b 3b 3b 20 09 09 20 20 23 74 29 ata).;;; .. #t)
4470: 0a 3b 3b 3b 20 09 09 20 28 28 64 62 72 65 61 64 .;;; .. ((dbread
4480: 29 20 3b 3b 20 54 4f 44 4f 3a 20 63 6f 6e 73 69 ) ;; TODO: consi
4490: 64 65 72 20 62 72 65 61 6b 69 6e 67 20 74 68 69 der breaking thi
44a0: 73 20 75 70 20 61 6e 64 20 73 68 69 70 70 69 6e s up and shippin
44b0: 67 20 69 6e 20 70 69 65 63 65 73 20 66 6f 72 20 g in pieces for
44c0: 6c 61 72 67 65 20 71 75 65 72 79 0a 3b 3b 3b 20 large query.;;;
44d0: 09 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 .. (apply sqlit
44e0: 65 33 3a 6d 61 70 2d 72 6f 77 20 28 6c 61 6d 62 e3:map-row (lamb
44f0: 64 61 20 78 20 78 29 20 73 74 68 20 64 61 74 61 da x x) sth data
4500: 29 29 0a 3b 3b 3b 20 09 09 20 28 28 66 75 6c 6c )).;;; .. ((full
4510: 2d 70 69 6e 67 29 20 20 27 66 75 6c 6c 2d 70 69 -ping) 'full-pi
4520: 6e 67 29 0a 3b 3b 3b 20 09 09 20 28 65 6c 73 65 ng).;;; .. (else
4530: 20 28 70 72 69 6e 74 20 22 4e 6f 74 20 72 65 61 (print "Not rea
4540: 64 79 20 66 6f 72 20 61 63 74 69 6f 6e 20 22 20 dy for action "
4550: 61 63 74 69 6f 6e 29 20 23 66 29 29 29 0a 3b 3b action) #f))).;;
4560: 3b 20 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ; . (loop (
4570: 61 64 64 31 20 63 6f 75 6e 74 29 0a 3b 3b 3b 20 add1 count).;;;
4580: 09 09 20 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 .. (if cookie
4590: 0a 3b 3b 3b 20 09 09 09 28 63 6f 6e 73 20 77 69 .;;; ...(cons wi
45a0: 74 65 6d 20 72 65 73 70 6f 6e 73 65 73 29 0a 3b tem responses).;
45b0: 3b 3b 20 09 09 09 72 65 73 70 6f 6e 73 65 73 29 ;; ...responses)
45c0: 29 29 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b ))))))).;;; .;;;
45d0: 20 3b 3b 20 64 6f 20 75 70 20 74 6f 20 34 30 30 ;; do up to 400
45e0: 6d 73 20 6f 66 20 70 72 6f 63 65 73 73 69 6e 67 ms of processing
45f0: 20 6f 6e 20 65 61 63 68 20 71 75 65 75 65 0a 3b on each queue.;
4600: 3b 3b 20 3b 3b 20 2d 20 74 68 65 20 77 6f 72 6b ;; ;; - the work
4610: 2d 71 75 65 75 65 2d 70 72 6f 63 65 73 73 6f 72 -queue-processor
4620: 20 77 69 6c 6c 20 61 6c 6c 6f 77 20 74 68 65 20 will allow the
4630: 6d 61 78 20 31 32 30 30 6d 73 20 6f 66 20 77 6f max 1200ms of wo
4640: 72 6b 20 74 6f 20 63 6f 6d 70 6c 65 74 65 20 62 rk to complete b
4650: 75 74 20 69 74 20 77 69 6c 6c 20 66 6c 61 67 20 ut it will flag
4660: 61 73 20 6f 76 65 72 6c 6f 61 64 65 64 0a 3b 3b as overloaded.;;
4670: 3b 20 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e ; ;; .;;; (defin
4680: 65 20 28 70 72 6f 63 65 73 73 2d 64 62 2d 71 75 e (process-db-qu
4690: 65 72 69 65 73 20 61 63 66 67 20 66 6e 61 6d 65 eries acfg fname
46a0: 29 0a 3b 3b 3b 20 20 20 28 69 66 20 28 68 61 73 ).;;; (if (has
46b0: 68 2d 74 61 62 6c 65 2d 65 78 69 73 74 73 3f 20 h-table-exists?
46c0: 28 61 72 65 61 2d 77 71 75 65 75 65 73 20 61 63 (area-wqueues ac
46d0: 66 67 29 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 fg) fname).;;;
46e0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 70 72 6f (let* ((pro
46f0: 63 65 73 73 2d 64 62 2d 71 75 65 72 69 65 73 2d cess-db-queries-
4700: 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
4710: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
4720: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 28 71 64 )).;;; . (qd
4730: 61 74 20 20 20 20 20 20 20 20 20 20 20 20 20 28 at (
4740: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4750: 65 66 61 75 6c 74 20 28 61 72 65 61 2d 77 71 75 efault (area-wqu
4760: 65 75 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 eues acfg) fname
4770: 20 23 66 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 #f)).;;; .
4780: 28 71 75 65 75 65 2d 73 79 6d 2d 3e 71 75 65 75 (queue-sym->queu
4790: 65 20 28 6c 61 6d 62 64 61 20 28 71 75 65 75 65 e (lambda (queue
47a0: 2d 73 79 6d 29 0a 3b 3b 3b 20 09 09 09 09 20 28 -sym).;;; .... (
47b0: 63 61 73 65 20 71 75 65 75 65 2d 73 79 6d 20 20 case queue-sym
47c0: 3b 3b 20 6c 6f 6f 6b 75 70 20 74 68 65 20 71 75 ;; lookup the qu
47d0: 65 75 65 20 66 72 6f 6d 20 71 64 61 74 20 67 69 eue from qdat gi
47e0: 76 65 6e 20 61 20 6e 61 6d 65 20 28 73 79 6d 62 ven a name (symb
47f0: 6f 6c 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 28 ol).;;; .... (
4800: 28 77 71 75 65 75 65 29 20 20 28 71 64 61 74 2d (wqueue) (qdat-
4810: 77 72 69 74 65 71 20 71 64 61 74 29 29 0a 3b 3b writeq qdat)).;;
4820: 3b 20 09 09 09 09 20 20 20 28 28 72 71 75 65 75 ; .... ((rqueu
4830: 65 29 20 20 28 71 64 61 74 2d 72 65 61 64 71 20 e) (qdat-readq
4840: 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 09 09 09 qdat)).;;; ....
4850: 20 20 20 28 28 72 77 71 75 65 75 65 29 20 28 71 ((rwqueue) (q
4860: 64 61 74 2d 72 77 71 20 20 20 20 71 64 61 74 29 dat-rwq qdat)
4870: 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 28 28 6d ).;;; .... ((m
4880: 69 73 63 29 20 20 20 20 28 71 64 61 74 2d 6d 69 isc) (qdat-mi
4890: 73 63 20 20 20 71 64 61 74 29 29 0a 3b 3b 3b 20 sc qdat)).;;;
48a0: 09 09 09 09 20 20 20 28 65 6c 73 65 20 23 66 29 .... (else #f)
48b0: 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 28 64 ))).;;; . (d
48c0: 62 64 61 74 20 20 20 28 67 65 74 2d 64 62 68 20 bdat (get-dbh
48d0: 61 63 66 67 20 66 6e 61 6d 65 29 29 0a 3b 3b 3b acfg fname)).;;;
48e0: 20 09 20 20 20 20 20 28 64 62 68 20 20 20 20 20 . (dbh
48f0: 28 69 66 20 28 64 62 64 61 74 3f 20 64 62 64 61 (if (dbdat? dbda
4900: 74 29 28 64 62 64 61 74 2d 64 62 68 20 64 62 64 t)(dbdat-dbh dbd
4910: 61 74 29 20 23 66 29 29 0a 3b 3b 3b 20 09 20 20 at) #f)).;;; .
4920: 20 20 20 28 6e 6f 77 74 69 6d 65 20 28 63 75 72 (nowtime (cur
4930: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
4940: 3b 3b 3b 20 09 3b 3b 20 68 61 6e 64 6c 65 20 74 ;;; .;; handle t
4950: 68 65 20 71 75 65 75 65 73 20 74 68 61 74 20 72 he queues that r
4960: 65 71 75 69 72 65 20 61 20 74 72 61 6e 73 61 63 equire a transac
4970: 74 69 6f 6e 0a 3b 3b 3b 20 09 3b 3b 0a 3b 3b 3b tion.;;; .;;.;;;
4980: 20 09 28 6d 61 70 20 3b 3b 20 0a 3b 3b 3b 20 09 .(map ;; .;;; .
4990: 20 28 6c 61 6d 62 64 61 20 28 71 75 65 75 65 2d (lambda (queue-
49a0: 73 79 6d 29 0a 3b 3b 3b 20 09 20 20 20 3b 3b 20 sym).;;; . ;;
49b0: 28 70 72 69 6e 74 20 22 70 72 6f 63 65 73 73 69 (print "processi
49c0: 6e 67 20 71 75 65 75 65 20 22 20 71 75 65 75 65 ng queue " queue
49d0: 2d 73 79 6d 29 0a 3b 3b 3b 20 09 20 20 20 28 6c -sym).;;; . (l
49e0: 65 74 2a 20 28 28 71 75 65 75 65 20 28 71 75 65 et* ((queue (que
49f0: 75 65 2d 73 79 6d 2d 3e 71 75 65 75 65 20 71 75 ue-sym->queue qu
4a00: 65 75 65 2d 73 79 6d 29 29 29 0a 3b 3b 3b 20 09 eue-sym))).;;; .
4a10: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 71 (if (not (q
4a20: 75 65 75 65 2d 65 6d 70 74 79 3f 20 71 75 65 75 ueue-empty? queu
4a30: 65 29 29 0a 3b 3b 3b 20 09 09 20 28 6c 65 74 20 e)).;;; .. (let
4a40: 28 28 72 65 73 70 6f 6e 73 65 73 0a 3b 3b 3b 20 ((responses.;;;
4a50: 09 09 09 28 73 71 6c 69 74 65 33 3a 77 69 74 68 ...(sqlite3:with
4a60: 2d 74 72 61 6e 73 61 63 74 69 6f 6e 20 3b 3b 20 -transaction ;;
4a70: 74 6f 64 6f 20 2d 20 63 61 74 63 68 20 65 78 63 todo - catch exc
4a80: 65 70 74 69 6f 6e 73 2e 2e 2e 0a 3b 3b 3b 20 09 eptions....;;; .
4a90: 09 09 20 64 62 68 0a 3b 3b 3b 20 09 09 09 20 28 .. dbh.;;; ... (
4aa0: 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 09 09 lambda ().;;; ..
4ab0: 09 20 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 . (let* ((res
4ac0: 28 64 6f 71 75 65 75 65 20 61 63 66 67 20 71 75 (doqueue acfg qu
4ad0: 65 75 65 20 66 6e 61 6d 65 20 64 62 64 61 74 20 eue fname dbdat
4ae0: 64 62 68 29 29 29 20 3b 3b 20 74 68 69 73 20 64 dbh))) ;; this d
4af0: 6f 65 73 20 74 68 65 20 77 6f 72 6b 21 0a 3b 3b oes the work!.;;
4b00: 3b 20 09 09 09 20 20 20 20 20 3b 3b 20 28 70 72 ; ... ;; (pr
4b10: 69 6e 74 20 22 72 65 73 3d 22 20 72 65 73 29 0a int "res=" res).
4b20: 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 6d 61 74 ;;; ... (mat
4b30: 63 68 20 72 65 73 0a 3b 3b 3b 20 09 09 09 20 20 ch res.;;; ...
4b40: 20 20 20 20 28 28 63 6f 75 6e 74 20 64 65 6c 74 ((count delt
4b50: 61 20 72 65 73 70 6f 6e 73 65 73 29 0a 3b 3b 3b a responses).;;;
4b60: 20 09 09 09 20 20 20 20 20 20 20 28 75 70 64 61 ... (upda
4b70: 74 65 2d 73 74 61 74 73 20 61 63 66 67 20 66 6e te-stats acfg fn
4b80: 61 6d 65 20 71 75 65 75 65 2d 73 79 6d 20 64 65 ame queue-sym de
4b90: 6c 74 61 20 63 6f 75 6e 74 29 0a 3b 3b 3b 20 09 lta count).;;; .
4ba0: 09 09 20 20 20 20 20 20 20 28 73 64 62 67 3e 20 .. (sdbg>
4bb0: 22 70 72 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 "process-db-quer
4bc0: 69 65 73 22 20 22 73 71 6c 69 74 65 33 2d 74 72 ies" "sqlite3-tr
4bd0: 61 6e 73 61 63 74 69 6f 6e 22 20 70 72 6f 63 65 ansaction" proce
4be0: 73 73 2d 64 62 2d 71 75 65 72 69 65 73 2d 73 74 ss-db-queries-st
4bf0: 61 72 74 2d 74 69 6d 65 20 23 66 20 23 66 29 0a art-time #f #f).
4c00: 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 20 72 65 ;;; ... re
4c10: 73 70 6f 6e 73 65 73 29 20 3b 3b 20 72 65 74 75 sponses) ;; retu
4c20: 72 6e 20 72 65 73 70 6f 6e 73 65 73 0a 3b 3b 3b rn responses.;;;
4c30: 20 09 09 09 20 20 20 20 20 20 28 65 6c 73 65 0a ... (else.
4c40: 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 20 28 70 ;;; ... (p
4c50: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 62 61 64 rint "ERROR: bad
4c60: 20 72 65 74 75 72 6e 20 64 61 74 61 20 66 72 6f return data fro
4c70: 6d 20 64 6f 71 75 65 75 65 20 22 20 72 65 73 29 m doqueue " res)
4c80: 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 29 )).;;; ... )
4c90: 29 29 29 29 0a 3b 3b 3b 20 09 09 20 20 20 3b 3b )))).;;; .. ;;
4ca0: 20 68 61 76 69 6e 67 20 63 6f 6d 70 6c 65 74 65 having complete
4cb0: 64 20 74 68 65 20 74 72 61 6e 73 61 63 74 69 6f d the transactio
4cc0: 6e 2c 20 73 65 6e 64 20 74 68 65 20 72 65 73 70 n, send the resp
4cd0: 6f 6e 73 65 73 2e 0a 3b 3b 3b 20 09 09 20 20 20 onses..;;; ..
4ce0: 3b 3b 20 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a ;; (print "INFO:
4cf0: 20 73 65 6e 64 69 6e 67 20 22 20 28 6c 65 6e 67 sending " (leng
4d00: 74 68 20 72 65 73 70 6f 6e 73 65 73 29 20 22 20 th responses) "
4d10: 72 65 73 70 6f 6e 73 65 73 2e 22 29 0a 3b 3b 3b responses.").;;;
4d20: 20 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 .. (let loop
4d30: 28 28 72 65 73 70 6f 6e 73 65 73 2d 6c 65 66 74 ((responses-left
4d40: 20 72 65 73 70 6f 6e 73 65 73 29 29 0a 3b 3b 3b responses)).;;;
4d50: 20 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b .. (cond.;;
4d60: 3b 20 09 09 20 20 20 20 20 20 28 28 6e 75 6c 6c ; .. ((null
4d70: 3f 20 72 65 73 70 6f 6e 73 65 73 2d 6c 65 66 74 ? responses-left
4d80: 29 20 20 23 74 29 0a 3b 3b 3b 20 09 09 20 20 20 ) #t).;;; ..
4d90: 20 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 09 20 (else.;;; ..
4da0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 77 69 (let* ((wi
4db0: 74 65 6d 20 20 20 20 28 63 61 72 20 72 65 73 70 tem (car resp
4dc0: 6f 6e 73 65 73 2d 6c 65 66 74 29 29 0a 3b 3b 3b onses-left)).;;;
4dd0: 20 09 09 09 20 20 20 20 20 20 28 72 65 73 70 6f ... (respo
4de0: 6e 73 65 20 28 63 64 72 20 72 65 73 70 6f 6e 73 nse (cdr respons
4df0: 65 73 2d 6c 65 66 74 29 29 29 20 20 0a 3b 3b 3b es-left))) .;;;
4e00: 20 09 09 09 20 28 63 61 6c 6c 2d 64 65 6c 69 76 ... (call-deliv
4e10: 65 72 2d 72 65 73 70 6f 6e 73 65 20 61 63 66 67 er-response acfg
4e20: 20 28 77 69 74 65 6d 2d 72 69 70 61 64 64 72 20 (witem-ripaddr
4e30: 77 69 74 65 6d 29 28 77 69 74 65 6d 2d 72 70 6f witem)(witem-rpo
4e40: 72 74 20 77 69 74 65 6d 29 0a 3b 3b 3b 20 09 09 rt witem).;;; ..
4e50: 09 09 09 09 28 77 69 74 65 6d 2d 63 6f 6f 6b 69 ....(witem-cooki
4e60: 65 20 77 69 74 65 6d 29 28 77 69 74 65 6d 2d 72 e witem)(witem-r
4e70: 65 73 75 6c 74 20 77 69 74 65 6d 29 29 29 0a 3b esult witem))).;
4e80: 3b 3b 20 09 09 20 20 20 20 20 20 20 28 6c 6f 6f ;; .. (loo
4e90: 70 20 28 63 64 72 20 72 65 73 70 6f 6e 73 65 73 p (cdr responses
4ea0: 2d 6c 65 66 74 29 29 29 29 29 29 0a 3b 3b 3b 20 -left)))))).;;;
4eb0: 09 09 20 29 29 29 0a 3b 3b 3b 20 09 20 27 28 77 .. ))).;;; . '(w
4ec0: 71 75 65 75 65 20 72 77 71 75 65 75 65 20 72 71 queue rwqueue rq
4ed0: 75 65 75 65 29 29 0a 3b 3b 3b 20 09 0a 3b 3b 3b ueue)).;;; ..;;;
4ee0: 20 09 3b 3b 20 68 61 6e 64 6c 65 20 6d 69 73 63 .;; handle misc
4ef0: 20 71 75 65 75 65 0a 3b 3b 3b 20 09 3b 3b 0a 3b queue.;;; .;;.;
4f00: 3b 3b 20 09 3b 3b 20 28 70 72 69 6e 74 20 22 70 ;; .;; (print "p
4f10: 72 6f 63 65 73 73 69 6e 67 20 6d 69 73 63 20 71 rocessing misc q
4f20: 75 65 75 65 22 29 0a 3b 3b 3b 20 09 28 6c 65 74 ueue").;;; .(let
4f30: 20 28 28 71 75 65 75 65 20 28 71 75 65 75 65 2d ((queue (queue-
4f40: 73 79 6d 2d 3e 71 75 65 75 65 20 27 6d 69 73 63 sym->queue 'misc
4f50: 29 29 29 0a 3b 3b 3b 20 09 20 20 28 64 6f 71 75 ))).;;; . (doqu
4f60: 65 75 65 20 61 63 66 67 20 71 75 65 75 65 20 66 eue acfg queue f
4f70: 6e 61 6d 65 20 64 62 64 61 74 20 64 62 68 29 29 name dbdat dbh))
4f80: 0a 3b 3b 3b 20 09 3b 3b 20 2e 2e 2e 2e 0a 3b 3b .;;; .;; .....;;
4f90: 3b 20 09 28 73 61 76 65 2d 64 62 68 20 61 63 66 ; .(save-dbh acf
4fa0: 67 20 66 6e 61 6d 65 20 64 62 64 61 74 29 0a 3b g fname dbdat).;
4fb0: 3b 3b 20 09 23 74 20 3b 3b 20 6a 75 73 74 20 74 ;; .#t ;; just t
4fc0: 6f 20 6c 65 74 20 74 68 65 20 74 65 73 74 73 20 o let the tests
4fd0: 6b 6e 6f 77 20 77 65 20 67 6f 74 20 68 65 72 65 know we got here
4fe0: 0a 3b 3b 3b 20 09 29 0a 3b 3b 3b 20 20 20 20 20 .;;; .).;;;
4ff0: 20 20 23 66 20 3b 3b 20 6e 6f 74 68 69 6e 67 20 #f ;; nothing
5000: 70 72 6f 63 65 73 73 65 64 0a 3b 3b 3b 20 20 20 processed.;;;
5010: 20 20 20 20 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 )).;;; .;;;
5020: 3b 3b 20 72 75 6e 20 61 6c 6c 20 71 75 65 75 65 ;; run all queue
5030: 73 20 69 6e 20 70 61 72 61 6c 6c 65 6c 20 70 65 s in parallel pe
5040: 72 20 64 62 20 62 75 74 20 73 65 71 75 65 6e 74 r db but sequent
5050: 69 61 6c 6c 79 20 70 65 72 20 71 75 65 75 65 20 ially per queue
5060: 66 6f 72 20 74 68 61 74 20 64 62 2e 0a 3b 3b 3b for that db..;;;
5070: 20 3b 3b 20 20 2d 20 70 72 6f 63 65 73 73 20 74 ;; - process t
5080: 68 65 20 71 75 65 75 65 73 20 65 76 65 72 79 20 he queues every
5090: 35 30 30 20 6f 72 20 73 6f 20 6d 73 0a 3b 3b 3b 500 or so ms.;;;
50a0: 20 3b 3b 20 20 2d 20 61 6c 6c 6f 77 20 66 6f 72 ;; - allow for
50b0: 20 6c 6f 6e 67 20 72 75 6e 6e 69 6e 67 20 71 75 long running qu
50c0: 65 72 69 65 73 20 74 6f 20 63 6f 6e 74 69 6e 75 eries to continu
50d0: 65 20 62 75 74 20 61 6c 6c 20 6f 74 68 65 72 20 e but all other
50e0: 61 63 74 69 76 69 74 69 65 73 20 66 6f 72 20 74 activities for t
50f0: 68 61 74 0a 3b 3b 3b 20 3b 3b 20 20 20 20 64 62 hat.;;; ;; db
5100: 20 77 69 6c 6c 20 62 65 20 62 6c 6f 63 6b 65 64 will be blocked
5110: 2e 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 ..;;; ;;.;;; (de
5120: 66 69 6e 65 20 28 77 6f 72 6b 2d 71 75 65 75 65 fine (work-queue
5130: 2d 70 72 6f 63 65 73 73 6f 72 20 61 63 66 67 29 -processor acfg)
5140: 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 74 .;;; (let* ((t
5150: 68 72 65 61 64 73 20 28 6d 61 6b 65 2d 68 61 73 hreads (make-has
5160: 68 2d 74 61 62 6c 65 29 29 29 20 3b 3b 20 66 6e h-table))) ;; fn
5170: 61 6d 65 20 3d 3e 20 74 68 72 65 61 64 0a 3b 3b ame => thread.;;
5180: 3b 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ; (let loop
5190: 28 28 66 6e 61 6d 65 73 20 20 20 20 20 20 28 68 ((fnames (h
51a0: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 28 ash-table-keys (
51b0: 61 72 65 61 2d 77 71 75 65 75 65 73 20 61 63 66 area-wqueues acf
51c0: 67 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 g))).;;; .
51d0: 20 28 74 61 72 67 65 74 2d 74 69 6d 65 20 28 2b (target-time (+
51e0: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
51f0: 65 63 6f 6e 64 73 29 20 35 30 29 29 29 0a 3b 3b econds) 50))).;;
5200: 3b 20 20 20 20 20 20 20 3b 3b 28 69 66 20 28 6e ; ;;(if (n
5210: 6f 74 20 28 6e 75 6c 6c 3f 20 66 6e 61 6d 65 73 ot (null? fnames
5220: 29 29 28 70 72 69 6e 74 20 22 50 72 6f 63 65 73 ))(print "Proces
5230: 73 69 6e 67 20 66 6f 72 20 74 68 65 73 65 20 64 sing for these d
5240: 61 74 61 62 61 73 65 73 3a 20 22 20 66 6e 61 6d atabases: " fnam
5250: 65 73 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 es)).;;; (
5260: 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 20 20 20 for-each.;;;
5270: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 66 6e 61 (lambda (fna
5280: 6d 65 29 0a 3b 3b 3b 20 09 20 3b 3b 20 28 70 72 me).;;; . ;; (pr
5290: 69 6e 74 20 22 70 72 6f 63 65 73 73 69 6e 67 20 int "processing
52a0: 66 6f 72 20 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b for " fname).;;;
52b0: 20 09 20 3b 3b 28 70 72 6f 63 65 73 73 2d 64 62 . ;;(process-db
52c0: 2d 71 75 65 72 69 65 73 20 61 63 66 67 20 66 6e -queries acfg fn
52d0: 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 28 6c 65 74 ame)).;;; . (let
52e0: 20 28 28 74 68 20 28 68 61 73 68 2d 74 61 62 6c ((th (hash-tabl
52f0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 68 e-ref/default th
5300: 72 65 61 64 73 20 66 6e 61 6d 65 20 23 66 29 29 reads fname #f))
5310: 29 0a 3b 3b 3b 20 09 20 20 20 28 69 66 20 28 61 ).;;; . (if (a
5320: 6e 64 20 74 68 20 28 6e 6f 74 20 28 6d 65 6d 62 nd th (not (memb
5330: 65 72 20 28 74 68 72 65 61 64 2d 73 74 61 74 65 er (thread-state
5340: 20 74 68 29 20 27 28 64 65 61 64 20 74 65 72 6d th) '(dead term
5350: 69 6e 61 74 65 64 29 29 29 29 0a 3b 3b 3b 20 09 inated)))).;;; .
5360: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b (begin.;;
5370: 3b 20 09 09 20 28 70 72 69 6e 74 20 22 57 41 52 ; .. (print "WAR
5380: 4e 49 4e 47 3a 20 77 6f 72 6b 65 72 20 74 68 72 NING: worker thr
5390: 65 61 64 20 66 6f 72 20 22 20 66 6e 61 6d 65 20 ead for " fname
53a0: 22 20 69 73 20 74 61 6b 69 6e 67 20 61 20 6c 6f " is taking a lo
53b0: 6e 67 20 74 69 6d 65 2e 22 29 0a 3b 3b 3b 20 09 ng time.").;;; .
53c0: 09 20 28 70 72 69 6e 74 20 22 54 68 72 65 61 64 . (print "Thread
53d0: 20 69 73 20 69 6e 20 73 74 61 74 65 20 22 20 28 is in state " (
53e0: 74 68 72 65 61 64 2d 73 74 61 74 65 20 74 68 29 thread-state th)
53f0: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 )).;;; . (
5400: 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b 65 2d let ((th1 (make-
5410: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
5420: 29 0a 3b 3b 3b 20 09 09 09 09 09 20 3b 3b 20 28 ).;;; ..... ;; (
5430: 63 61 74 63 68 2d 61 6e 64 2d 64 75 6d 70 0a 3b catch-and-dump.;
5440: 3b 3b 20 09 09 09 09 09 20 3b 3b 20 20 28 6c 61 ;; ..... ;; (la
5450: 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 09 09 09 09 mbda ().;;; ....
5460: 09 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 . ;; (print "
5470: 50 72 6f 63 65 73 73 20 71 75 65 72 69 65 73 20 Process queries
5480: 66 6f 72 20 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b for " fname).;;;
5490: 20 09 09 09 09 09 20 20 20 20 28 6c 65 74 20 28 ..... (let (
54a0: 28 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 (start-time (cur
54b0: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
54c0: 73 29 29 29 0a 3b 3b 3b 20 09 09 09 09 09 20 20 s))).;;; .....
54d0: 20 20 20 20 28 70 72 6f 63 65 73 73 2d 64 62 2d (process-db-
54e0: 71 75 65 72 69 65 73 20 61 63 66 67 20 66 6e 61 queries acfg fna
54f0: 6d 65 29 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 me).;;; .....
5500: 20 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c ;; (thread-sl
5510: 65 65 70 21 20 30 2e 30 31 29 20 3b 3b 20 6e 65 eep! 0.01) ;; ne
5520: 65 64 20 74 68 65 20 74 68 72 65 61 64 20 74 6f ed the thread to
5530: 20 74 61 6b 65 20 61 74 20 6c 65 61 73 74 20 73 take at least s
5540: 6f 6d 65 20 74 69 6d 65 0a 3b 3b 3b 20 09 09 09 ome time.;;; ...
5550: 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 .. (hash-ta
5560: 62 6c 65 2d 64 65 6c 65 74 65 21 20 74 68 72 65 ble-delete! thre
5570: 61 64 73 20 66 6e 61 6d 65 29 29 20 3b 3b 20 6e ads fname)) ;; n
5580: 6f 20 6d 75 74 65 78 65 73 3f 0a 3b 3b 3b 20 09 o mutexes?.;;; .
5590: 09 09 09 09 20 20 20 20 66 6e 61 6d 65 29 0a 3b .... fname).;
55a0: 3b 3b 20 09 09 09 09 09 20 20 22 74 68 31 22 29 ;; ..... "th1")
55b0: 29 29 20 3b 3b 20 29 29 0a 3b 3b 3b 20 09 09 20 )) ;; )).;;; ..
55c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
55d0: 20 74 68 72 65 61 64 73 20 66 6e 61 6d 65 20 74 threads fname t
55e0: 68 31 29 0a 3b 3b 3b 20 09 09 20 28 74 68 72 65 h1).;;; .. (thre
55f0: 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 29 29 ad-start! th1)))
5600: 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 66 6e )).;;; fn
5610: 61 6d 65 73 29 0a 3b 3b 3b 20 20 20 20 20 20 20 ames).;;;
5620: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
5630: 21 20 30 2e 31 29 20 3b 3b 20 67 69 76 65 20 74 ! 0.1) ;; give t
5640: 68 65 20 74 68 72 65 61 64 73 20 73 6f 6d 65 20 he threads some
5650: 74 69 6d 65 20 74 6f 20 70 72 6f 63 65 73 73 20 time to process
5660: 72 65 71 75 65 73 74 73 0a 3b 3b 3b 20 20 20 20 requests.;;;
5670: 20 20 20 3b 3b 20 62 75 72 6e 20 74 69 6d 65 20 ;; burn time
5680: 75 6e 74 69 6c 20 34 30 30 6d 73 20 69 73 20 75 until 400ms is u
5690: 70 0a 3b 3b 3b 20 20 20 20 20 20 20 28 6c 65 74 p.;;; (let
56a0: 20 28 28 6e 6f 77 2d 74 69 6d 65 20 28 63 75 72 ((now-time (cur
56b0: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
56c0: 73 29 29 29 0a 3b 3b 3b 20 09 28 69 66 20 28 3c s))).;;; .(if (<
56d0: 20 6e 6f 77 2d 74 69 6d 65 20 74 61 72 67 65 74 now-time target
56e0: 2d 74 69 6d 65 29 0a 3b 3b 3b 20 09 20 20 20 20 -time).;;; .
56f0: 28 6c 65 74 20 28 28 64 65 6c 74 61 20 28 2d 20 (let ((delta (-
5700: 74 61 72 67 65 74 2d 74 69 6d 65 20 6e 6f 77 2d target-time now-
5710: 74 69 6d 65 29 29 29 0a 3b 3b 3b 20 09 20 20 20 time))).;;; .
5720: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
5730: 21 20 28 2f 20 64 65 6c 74 61 20 31 30 30 30 29 ! (/ delta 1000)
5740: 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 )))).;;; (
5750: 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 6c 65 loop (hash-table
5760: 2d 6b 65 79 73 20 28 61 72 65 61 2d 77 71 75 65 -keys (area-wque
5770: 75 65 73 20 61 63 66 67 29 29 0a 3b 3b 3b 20 09 ues acfg)).;;; .
5780: 20 20 20 20 28 2b 20 28 63 75 72 72 65 6e 74 2d (+ (current-
5790: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 35 30 milliseconds) 50
57a0: 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b ))))).;;; .;;; ;
57b0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
57c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
57d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
57e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
57f0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 53 =======.;;; ;; S
5800: 20 54 20 41 20 54 20 53 20 20 20 47 20 41 20 54 T A T S G A T
5810: 20 48 20 45 20 52 20 49 20 4e 20 47 0a 3b 3b 3b H E R I N G.;;;
5820: 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;=============
5830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b =========.;;; .;
5870: 3b 3b 20 28 64 65 66 73 74 72 75 63 74 20 73 74 ;; (defstruct st
5880: 61 74 0a 3b 3b 3b 20 20 20 28 71 63 6f 75 6e 74 at.;;; (qcount
5890: 2d 61 76 67 20 20 30 29 20 20 20 20 20 20 20 20 -avg 0)
58a0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 6f 61 ;; coa
58b0: 72 73 65 20 72 75 6e 6e 69 6e 67 20 61 76 65 72 rse running aver
58c0: 61 67 65 0a 3b 3b 3b 20 20 20 28 71 74 69 6d 65 age.;;; (qtime
58d0: 2d 61 76 67 20 20 20 30 29 20 20 20 20 20 20 20 -avg 0)
58e0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 6f ;; co
58f0: 61 72 73 65 20 72 75 6e 6e 69 6e 67 20 61 76 65 arse running ave
5900: 72 61 67 65 0a 3b 3b 3b 20 20 20 28 71 63 6f 75 rage.;;; (qcou
5910: 6e 74 20 20 20 20 20 20 30 29 20 20 20 20 20 20 nt 0)
5920: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
5930: 6f 74 61 6c 0a 3b 3b 3b 20 20 20 28 71 74 69 6d otal.;;; (qtim
5940: 65 20 20 20 20 20 20 20 30 29 20 20 20 20 20 20 e 0)
5950: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
5960: 6f 74 61 6c 0a 3b 3b 3b 20 20 20 28 6c 61 73 74 otal.;;; (last
5970: 2d 71 63 6f 75 6e 74 20 30 29 20 20 20 20 20 20 -qcount 0)
5980: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6c ;; l
5990: 61 73 74 20 0a 3b 3b 3b 20 20 20 28 6c 61 73 74 ast .;;; (last
59a0: 2d 71 74 69 6d 65 20 20 30 29 20 20 20 20 20 20 -qtime 0)
59b0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6c ;; l
59c0: 61 73 74 0a 3b 3b 3b 20 20 20 28 64 62 73 20 20 ast.;;; (dbs
59d0: 20 20 20 20 20 20 27 28 29 29 20 20 20 20 20 20 '())
59e0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 69 ;; li
59f0: 73 74 20 6f 66 20 64 62 20 66 69 6c 65 73 20 68 st of db files h
5a00: 61 6e 64 6c 65 64 20 62 79 20 74 68 69 73 20 6e andled by this n
5a10: 6f 64 65 0a 3b 3b 3b 20 20 20 28 77 68 65 6e 20 ode.;;; (when
5a20: 20 20 20 20 20 20 20 30 29 29 20 20 20 20 20 20 0))
5a30: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 77 68 ;; wh
5a40: 65 6e 20 74 68 65 20 6c 61 73 74 20 71 75 65 72 en the last quer
5a50: 79 20 68 61 70 70 65 6e 65 64 20 2d 20 73 65 63 y happened - sec
5a60: 6f 6e 64 73 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 3b onds.;;; .;;; .;
5a70: 3b 3b 20 28 64 65 66 69 6e 65 20 28 75 70 64 61 ;; (define (upda
5a80: 74 65 2d 73 74 61 74 73 20 61 63 66 67 20 66 6e te-stats acfg fn
5a90: 61 6d 65 20 62 75 63 6b 65 74 20 64 75 72 61 74 ame bucket durat
5aa0: 69 6f 6e 20 6e 75 6d 71 75 65 72 69 65 73 29 0a ion numqueries).
5ab0: 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 ;;; (let* ((ke
5ac0: 79 20 20 20 66 6e 61 6d 65 29 20 3b 3b 20 66 6f y fname) ;; fo
5ad0: 72 20 6e 6f 77 20 64 6f 20 6e 6f 74 20 75 73 65 r now do not use
5ae0: 20 62 75 63 6b 65 74 2e 20 57 61 73 3a 20 28 63 bucket. Was: (c
5af0: 6f 6e 63 20 66 6e 61 6d 65 20 22 2d 22 20 62 75 onc fname "-" bu
5b00: 63 6b 65 74 29 29 20 3b 3b 20 6c 61 7a 79 20 62 cket)) ;; lazy b
5b10: 75 74 20 67 6f 6f 64 20 65 6e 6f 75 67 68 0a 3b ut good enough.;
5b20: 3b 3b 20 09 20 28 73 74 61 74 73 20 28 6f 72 20 ;; . (stats (or
5b30: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
5b40: 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d 73 74 default (area-st
5b50: 61 74 73 20 61 63 66 67 29 20 6b 65 79 20 23 66 ats acfg) key #f
5b60: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 28 6c 65 74 ).;;; .. (let
5b70: 20 28 28 6e 65 77 73 74 61 74 73 20 28 6d 61 6b ((newstats (mak
5b80: 65 2d 73 74 61 74 29 29 29 0a 3b 3b 3b 20 09 09 e-stat))).;;; ..
5b90: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
5ba0: 65 2d 73 65 74 21 20 28 61 72 65 61 2d 73 74 61 e-set! (area-sta
5bb0: 74 73 20 61 63 66 67 29 20 6b 65 79 20 6e 65 77 ts acfg) key new
5bc0: 73 74 61 74 73 29 0a 3b 3b 3b 20 09 09 20 20 20 stats).;;; ..
5bd0: 20 20 20 6e 65 77 73 74 61 74 73 29 29 29 29 0a newstats)))).
5be0: 3b 3b 3b 20 20 20 20 20 3b 3b 20 77 68 65 6e 20 ;;; ;; when
5bf0: 74 68 65 20 6c 61 73 74 20 71 75 65 72 79 20 68 the last query h
5c00: 61 70 70 65 6e 64 65 64 20 28 75 73 65 64 20 74 appended (used t
5c10: 6f 20 72 65 6d 6f 76 65 20 74 68 65 20 66 6e 61 o remove the fna
5c20: 6d 65 20 66 72 6f 6d 20 74 68 65 20 61 63 74 69 me from the acti
5c30: 76 65 20 6c 69 73 74 29 0a 3b 3b 3b 20 20 20 20 ve list).;;;
5c40: 20 28 73 74 61 74 2d 77 68 65 6e 2d 73 65 74 21 (stat-when-set!
5c50: 20 73 74 61 74 73 20 28 63 75 72 72 65 6e 74 2d stats (current-
5c60: 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 20 20 seconds)).;;;
5c70: 20 20 3b 3b 20 6c 61 73 74 20 76 61 6c 75 65 73 ;; last values
5c80: 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 2d 6c .;;; (stat-l
5c90: 61 73 74 2d 71 63 6f 75 6e 74 2d 73 65 74 21 20 ast-qcount-set!
5ca0: 73 74 61 74 73 20 6e 75 6d 71 75 65 72 69 65 73 stats numqueries
5cb0: 29 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 2d ).;;; (stat-
5cc0: 6c 61 73 74 2d 71 74 69 6d 65 2d 73 65 74 21 20 last-qtime-set!
5cd0: 20 73 74 61 74 73 20 64 75 72 61 74 69 6f 6e 29 stats duration)
5ce0: 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 74 6f 74 61 .;;; ;; tota
5cf0: 6c 20 6f 76 65 72 20 70 72 6f 63 65 73 73 20 6c l over process l
5d00: 69 66 65 74 69 6d 65 0a 3b 3b 3b 20 20 20 20 20 ifetime.;;;
5d10: 28 73 74 61 74 2d 71 63 6f 75 6e 74 2d 73 65 74 (stat-qcount-set
5d20: 21 20 73 74 61 74 73 20 28 2b 20 28 73 74 61 74 ! stats (+ (stat
5d30: 2d 71 63 6f 75 6e 74 20 73 74 61 74 73 29 20 6e -qcount stats) n
5d40: 75 6d 71 75 65 72 69 65 73 29 29 0a 3b 3b 3b 20 umqueries)).;;;
5d50: 20 20 20 20 28 73 74 61 74 2d 71 74 69 6d 65 2d (stat-qtime-
5d60: 73 65 74 21 20 20 73 74 61 74 73 20 28 2b 20 28 set! stats (+ (
5d70: 73 74 61 74 2d 71 74 69 6d 65 20 20 73 74 61 74 stat-qtime stat
5d80: 73 29 20 64 75 72 61 74 69 6f 6e 29 29 0a 3b 3b s) duration)).;;
5d90: 3b 20 20 20 20 20 3b 3b 20 63 6f 61 72 73 65 20 ; ;; coarse
5da0: 61 76 65 72 61 67 65 0a 3b 3b 3b 20 20 20 20 20 average.;;;
5db0: 28 73 74 61 74 2d 71 63 6f 75 6e 74 2d 61 76 67 (stat-qcount-avg
5dc0: 2d 73 65 74 21 20 73 74 61 74 73 20 28 2f 20 28 -set! stats (/ (
5dd0: 2b 20 28 73 74 61 74 2d 71 63 6f 75 6e 74 2d 61 + (stat-qcount-a
5de0: 76 67 20 73 74 61 74 73 29 20 6e 75 6d 71 75 65 vg stats) numque
5df0: 72 69 65 73 29 20 32 29 29 0a 3b 3b 3b 20 20 20 ries) 2)).;;;
5e00: 20 20 28 73 74 61 74 2d 71 74 69 6d 65 2d 61 76 (stat-qtime-av
5e10: 67 2d 73 65 74 21 20 20 73 74 61 74 73 20 28 2f g-set! stats (/
5e20: 20 28 2b 20 28 73 74 61 74 2d 71 74 69 6d 65 2d (+ (stat-qtime-
5e30: 61 76 67 20 20 73 74 61 74 73 29 20 64 75 72 61 avg stats) dura
5e40: 74 69 6f 6e 29 20 20 20 32 29 29 0a 3b 3b 3b 20 tion) 2)).;;;
5e50: 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 68 65 72 65 .;;; ;; here
5e60: 20 69 73 20 77 68 65 72 65 20 77 65 20 61 64 64 is where we add
5e70: 20 74 68 65 20 73 74 61 74 73 20 66 6f 72 20 61 the stats for a
5e80: 20 67 69 76 65 6e 20 64 62 66 69 6c 65 0a 3b 3b given dbfile.;;
5e90: 3b 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ; (if (not (
5ea0: 6d 65 6d 62 65 72 20 66 6e 61 6d 65 20 28 73 74 member fname (st
5eb0: 61 74 2d 64 62 73 20 73 74 61 74 73 29 29 29 0a at-dbs stats))).
5ec0: 3b 3b 3b 20 09 28 73 74 61 74 2d 64 62 73 2d 73 ;;; .(stat-dbs-s
5ed0: 65 74 21 20 73 74 61 74 73 20 28 63 6f 6e 73 20 et! stats (cons
5ee0: 66 6e 61 6d 65 20 28 73 74 61 74 2d 64 62 73 20 fname (stat-dbs
5ef0: 73 74 61 74 73 29 29 29 29 0a 3b 3b 3b 20 0a 3b stats)))).;;; .;
5f00: 3b 3b 20 20 20 20 20 29 29 0a 3b 3b 3b 20 0a 3b ;; )).;;; .;
5f10: 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;; ;;===========
5f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 ===========.;;;
5f60: 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 20 20 ;; S E R V E R
5f70: 20 53 20 54 20 55 20 46 20 46 20 0a 3b 3b 3b 20 S T U F F .;;;
5f80: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
5f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fc0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b ========.;;; .;;
5fd0: 3b 20 3b 3b 20 74 68 69 73 20 64 6f 65 73 20 4e ; ;; this does N
5fe0: 4f 54 20 72 65 74 75 72 6e 21 0a 3b 3b 3b 20 3b OT return!.;;; ;
5ff0: 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 66 ;.;;; (define (f
6000: 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e ind-free-port-an
6010: 64 2d 6f 70 65 6e 20 61 63 66 67 29 0a 3b 3b 3b d-open acfg).;;;
6020: 20 20 20 28 6c 65 74 20 28 28 70 6f 72 74 20 28 (let ((port (
6030: 6f 72 20 28 61 72 65 61 2d 70 6f 72 74 20 61 63 or (area-port ac
6040: 66 67 29 20 33 32 30 30 29 29 29 0a 3b 3b 3b 20 fg) 3200))).;;;
6050: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
6060: 70 74 69 6f 6e 73 0a 3b 3b 3b 20 09 65 78 6e 0a ptions.;;; .exn.
6070: 3b 3b 3b 20 09 28 62 65 67 69 6e 0a 3b 3b 3b 20 ;;; .(begin.;;;
6080: 09 20 20 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a . (print "INFO:
6090: 20 63 61 6e 6e 6f 74 20 62 69 6e 64 20 74 6f 20 cannot bind to
60a0: 70 6f 72 74 20 22 20 28 72 70 63 3a 64 65 66 61 port " (rpc:defa
60b0: 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 74 29 ult-server-port)
60c0: 20 22 2c 20 74 72 79 69 6e 67 20 6e 65 78 74 20 ", trying next
60d0: 70 6f 72 74 22 29 0a 3b 3b 3b 20 09 20 20 28 61 port").;;; . (a
60e0: 72 65 61 2d 70 6f 72 74 2d 73 65 74 21 20 61 63 rea-port-set! ac
60f0: 66 67 20 28 2b 20 70 6f 72 74 20 31 29 29 0a 3b fg (+ port 1)).;
6100: 3b 3b 20 09 20 20 28 66 69 6e 64 2d 66 72 65 65 ;; . (find-free
6110: 2d 70 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 61 -port-and-open a
6120: 63 66 67 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 cfg)).;;;
6130: 28 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 (rpc:default-ser
6140: 76 65 72 2d 70 6f 72 74 20 70 6f 72 74 29 0a 3b ver-port port).;
6150: 3b 3b 20 20 20 20 20 20 20 28 61 72 65 61 2d 70 ;; (area-p
6160: 6f 72 74 2d 73 65 74 21 20 61 63 66 67 20 70 6f ort-set! acfg po
6170: 72 74 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 74 rt).;;; (t
6180: 63 70 2d 72 65 61 64 2d 74 69 6d 65 6f 75 74 20 cp-read-timeout
6190: 31 32 30 30 30 30 29 0a 3b 3b 3b 20 20 20 20 20 120000).;;;
61a0: 20 20 3b 3b 20 28 28 72 70 63 3a 6d 61 6b 65 2d ;; ((rpc:make-
61b0: 73 65 72 76 65 72 20 28 74 63 70 2d 6c 69 73 74 server (tcp-list
61c0: 65 6e 20 70 6f 72 74 29 29 20 23 74 29 0a 3b 3b en port)) #t).;;
61d0: 3b 20 20 20 20 20 20 20 28 74 63 70 2d 6c 69 73 ; (tcp-lis
61e0: 74 65 6e 20 28 72 70 63 3a 64 65 66 61 75 6c 74 ten (rpc:default
61f0: 2d 73 65 72 76 65 72 2d 70 6f 72 74 29 0a 3b 3b -server-port).;;
6200: 3b 20 20 20 20 20 20 20 29 29 29 29 0a 3b 3b 3b ; )))).;;;
6210: 20 0a 3b 3b 3b 20 3b 3b 20 72 65 67 69 73 74 65 .;;; ;; registe
6220: 72 20 74 68 69 73 20 6e 6f 64 65 20 62 79 20 70 r this node by p
6230: 75 74 74 69 6e 67 20 61 20 70 61 63 6b 65 74 20 utting a packet
6240: 69 6e 74 6f 20 74 68 65 20 70 6b 74 73 20 64 69 into the pkts di
6250: 72 2e 0a 3b 3b 3b 20 3b 3b 20 6c 6f 6f 6b 20 66 r..;;; ;; look f
6260: 6f 72 20 6f 74 68 65 72 20 73 65 72 76 65 72 73 or other servers
6270: 0a 3b 3b 3b 20 3b 3b 20 63 6f 6e 74 61 63 74 20 .;;; ;; contact
6280: 6f 74 68 65 72 20 73 65 72 76 65 72 73 20 61 6e other servers an
6290: 64 20 63 6f 6d 70 69 6c 65 20 6c 69 73 74 20 6f d compile list o
62a0: 66 20 73 65 72 76 65 72 73 0a 3b 3b 3b 20 3b 3b f servers.;;; ;;
62b0: 20 74 68 65 72 65 20 61 72 65 20 74 77 6f 20 74 there are two t
62c0: 79 70 65 73 20 6f 66 20 73 65 72 76 65 72 0a 3b ypes of server.;
62d0: 3b 3b 20 3b 3b 20 20 20 20 20 6d 61 69 6e 20 73 ;; ;; main s
62e0: 65 72 76 65 72 73 20 2d 20 64 61 73 68 62 6f 61 ervers - dashboa
62f0: 72 64 73 2c 20 72 75 6e 6e 65 72 73 20 61 6e 64 rds, runners and
6300: 20 64 65 64 69 63 61 74 65 64 20 73 65 72 76 65 dedicated serve
6310: 72 73 20 2d 20 6e 65 65 64 20 70 6b 74 0a 3b 3b rs - need pkt.;;
6320: 3b 20 3b 3b 20 20 20 20 20 70 61 73 73 69 76 65 ; ;; passive
6330: 20 73 65 72 76 65 72 73 20 2d 20 74 65 73 74 20 servers - test
6340: 65 78 65 63 75 74 65 72 73 2c 20 73 74 65 70 20 executers, step
6350: 63 61 6c 6c 73 2c 20 6c 69 73 74 2d 72 75 6e 73 calls, list-runs
6360: 20 2d 20 6e 6f 20 70 6b 74 0a 3b 3b 3b 20 3b 3b - no pkt.;;; ;;
6370: 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 65 .;;; (define (re
6380: 67 69 73 74 65 72 2d 6e 6f 64 65 20 61 63 66 67 gister-node acfg
6390: 20 68 6f 73 74 69 70 20 70 6f 72 74 2d 6e 75 6d hostip port-num
63a0: 29 0a 3b 3b 3b 20 20 20 3b 3b 28 6d 75 74 65 78 ).;;; ;;(mutex
63b0: 2d 6c 6f 63 6b 21 20 28 61 72 65 61 2d 6d 75 74 -lock! (area-mut
63c0: 65 78 20 61 63 66 67 29 29 0a 3b 3b 3b 20 20 20 ex acfg)).;;;
63d0: 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 74 (let* ((server-t
63e0: 79 70 65 20 20 28 61 72 65 61 2d 73 65 72 76 65 ype (area-serve
63f0: 72 2d 74 79 70 65 20 61 63 66 67 29 29 20 3b 3b r-type acfg)) ;;
6400: 20 61 75 74 6f 2c 20 6d 61 69 6e 2c 20 70 61 73 auto, main, pas
6410: 73 69 76 65 20 28 6e 6f 20 70 6b 74 20 63 72 65 sive (no pkt cre
6420: 61 74 65 64 29 0a 3b 3b 3b 20 09 20 28 62 65 73 ated).;;; . (bes
6430: 74 2d 69 70 20 20 20 20 20 20 28 6f 72 20 68 6f t-ip (or ho
6440: 73 74 69 70 20 28 67 65 74 2d 6d 79 2d 62 65 73 stip (get-my-bes
6450: 74 2d 61 64 64 72 65 73 73 29 29 29 0a 3b 3b 3b t-address))).;;;
6460: 20 09 20 28 6d 74 64 69 72 20 20 20 20 20 20 20 . (mtdir
6470: 20 28 61 72 65 61 2d 64 62 64 69 72 20 61 63 66 (area-dbdir acf
6480: 67 29 29 0a 3b 3b 3b 20 09 20 28 70 6b 74 64 69 g)).;;; . (pktdi
6490: 72 20 20 20 20 20 20 20 28 61 72 65 61 2d 70 6b r (area-pk
64a0: 74 73 64 69 72 20 61 63 66 67 29 29 29 20 3b 3b tsdir acfg))) ;;
64b0: 20 63 6f 6e 63 20 6d 74 64 69 72 20 22 2f 2e 73 conc mtdir "/.s
64c0: 65 72 76 65 72 2d 70 6b 74 73 22 29 29 29 0a 3b erver-pkts"))).;
64d0: 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 52 ;; (print "R
64e0: 65 67 69 73 74 65 72 69 6e 67 20 6e 6f 64 65 20 egistering node
64f0: 22 20 62 65 73 74 2d 69 70 20 22 3a 22 20 70 6f " best-ip ":" po
6500: 72 74 2d 6e 75 6d 29 0a 3b 3b 3b 20 20 20 20 20 rt-num).;;;
6510: 28 69 66 20 28 6e 6f 74 20 6d 74 64 69 72 29 20 (if (not mtdir)
6520: 3b 3b 20 72 65 71 75 69 72 65 20 61 20 68 6f 6d ;; require a hom
6530: 65 20 66 6f 72 20 74 68 69 73 20 6e 6f 64 65 20 e for this node
6540: 74 6f 20 70 75 74 20 6f 72 20 66 69 6e 64 20 64 to put or find d
6550: 61 74 61 62 61 73 65 73 0a 3b 3b 3b 20 09 23 66 atabases.;;; .#f
6560: 0a 3b 3b 3b 20 09 28 62 65 67 69 6e 0a 3b 3b 3b .;;; .(begin.;;;
6570: 20 09 20 20 28 69 66 20 20 28 6e 6f 74 20 28 64 . (if (not (d
6580: 69 72 65 63 74 6f 72 79 3f 20 70 6b 74 64 69 72 irectory? pktdir
6590: 29 29 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 ))(create-direct
65a0: 6f 72 79 20 70 6b 74 64 69 72 29 29 0a 3b 3b 3b ory pktdir)).;;;
65b0: 20 09 20 20 3b 3b 20 73 65 72 76 65 72 20 69 73 . ;; server is
65c0: 20 73 74 61 72 74 65 64 2c 20 6e 6f 77 20 63 72 started, now cr
65d0: 65 61 74 65 20 70 6b 74 20 69 66 20 6e 65 65 64 eate pkt if need
65e0: 65 64 0a 3b 3b 3b 20 09 20 20 28 70 72 69 6e 74 ed.;;; . (print
65f0: 20 22 53 74 61 72 74 69 6e 67 20 73 65 72 76 65 "Starting serve
6600: 72 20 69 6e 20 22 20 73 65 72 76 65 72 2d 74 79 r in " server-ty
6610: 70 65 20 22 20 6d 6f 64 65 20 77 69 74 68 20 70 pe " mode with p
6620: 6f 72 74 20 22 20 70 6f 72 74 2d 6e 75 6d 29 0a ort " port-num).
6630: 3b 3b 3b 20 09 20 20 28 69 66 20 28 6d 65 6d 62 ;;; . (if (memb
6640: 65 72 20 73 65 72 76 65 72 2d 74 79 70 65 20 27 er server-type '
6650: 28 61 75 74 6f 20 6d 61 69 6e 29 29 20 3b 3b 20 (auto main)) ;;
6660: 54 4f 44 4f 3a 20 69 66 20 61 75 74 6f 2c 20 63 TODO: if auto, c
6670: 6f 75 6e 74 20 6e 75 6d 62 65 72 20 6f 66 20 73 ount number of s
6680: 65 72 76 65 72 73 20 72 65 67 69 73 74 65 72 73 ervers registers
6690: 2c 20 69 66 20 3e 20 33 20 74 68 65 6e 20 64 6f , if > 3 then do
66a0: 6e 27 74 20 70 75 74 20 6f 75 74 20 61 20 70 6b n't put out a pk
66b0: 74 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 62 65 t.;;; . (be
66c0: 67 69 6e 0a 3b 3b 3b 20 09 09 28 61 72 65 61 2d gin.;;; ..(area-
66d0: 70 6b 74 69 64 2d 73 65 74 21 20 61 63 66 67 0a pktid-set! acfg.
66e0: 3b 3b 3b 20 09 09 09 09 20 28 77 72 69 74 65 2d ;;; .... (write-
66f0: 61 6c 69 73 74 2d 3e 70 6b 74 0a 3b 3b 3b 20 09 alist->pkt.;;; .
6700: 09 09 09 20 20 70 6b 74 64 69 72 20 0a 3b 3b 3b ... pktdir .;;;
6710: 20 09 09 09 09 20 20 60 28 28 68 6f 73 74 6e 61 .... `((hostna
6720: 6d 65 20 2e 20 2c 28 67 65 74 2d 68 6f 73 74 2d me . ,(get-host-
6730: 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 09 09 09 20 name)).;;; ....
6740: 20 20 20 28 69 70 61 64 64 72 20 20 20 2e 20 2c (ipaddr . ,
6750: 62 65 73 74 2d 69 70 29 0a 3b 3b 3b 20 09 09 09 best-ip).;;; ...
6760: 09 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 2e . (port .
6770: 20 2c 70 6f 72 74 2d 6e 75 6d 29 0a 3b 3b 3b 20 ,port-num).;;;
6780: 09 09 09 09 20 20 20 20 28 70 69 64 20 20 20 20 .... (pid
6790: 20 20 2e 20 2c 28 63 75 72 72 65 6e 74 2d 70 72 . ,(current-pr
67a0: 6f 63 65 73 73 2d 69 64 29 29 29 0a 3b 3b 3b 20 ocess-id))).;;;
67b0: 09 09 09 09 20 20 70 6b 74 73 70 65 63 3a 20 2a .... pktspec: *
67c0: 70 6b 74 73 70 65 63 2a 0a 3b 3b 3b 20 09 09 09 pktspec*.;;; ...
67d0: 09 20 20 70 74 79 70 65 3a 20 20 20 27 73 65 72 . ptype: 'ser
67e0: 76 65 72 29 29 0a 3b 3b 3b 20 09 09 28 61 72 65 ver)).;;; ..(are
67f0: 61 2d 70 6b 74 66 69 6c 65 2d 73 65 74 21 20 61 a-pktfile-set! a
6800: 63 66 67 20 28 63 6f 6e 63 20 70 6b 74 64 69 72 cfg (conc pktdir
6810: 20 22 2f 22 20 28 61 72 65 61 2d 70 6b 74 69 64 "/" (area-pktid
6820: 20 61 63 66 67 29 20 22 2e 70 6b 74 22 29 29 29 acfg) ".pkt")))
6830: 29 0a 3b 3b 3b 20 09 20 20 28 61 72 65 61 2d 70 ).;;; . (area-p
6840: 6f 72 74 2d 73 65 74 21 20 20 20 20 61 63 66 67 ort-set! acfg
6850: 20 70 6f 72 74 2d 6e 75 6d 29 0a 3b 3b 3b 20 09 port-num).;;; .
6860: 20 20 23 3b 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 #;(mutex-unloc
6870: 6b 21 20 28 61 72 65 61 2d 6d 75 74 65 78 20 61 k! (area-mutex a
6880: 63 66 67 29 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b cfg)))))).;;; .;
6890: 3b 3b 20 28 64 65 66 69 6e 65 20 2a 63 6f 6f 6b ;; (define *cook
68a0: 69 65 2d 73 65 71 6e 75 6d 2a 20 30 29 0a 3b 3b ie-seqnum* 0).;;
68b0: 3b 20 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d ; (define (make-
68c0: 63 6f 6f 6b 69 65 20 6b 65 79 29 0a 3b 3b 3b 20 cookie key).;;;
68d0: 20 20 28 73 65 74 21 20 2a 63 6f 6f 6b 69 65 2d (set! *cookie-
68e0: 73 65 71 6e 75 6d 2a 20 28 61 64 64 31 20 2a 63 seqnum* (add1 *c
68f0: 6f 6f 6b 69 65 2d 73 65 71 6e 75 6d 2a 29 29 0a ookie-seqnum*)).
6900: 3b 3b 3b 20 20 20 3b 3b 28 70 72 69 6e 74 20 22 ;;; ;;(print "
6910: 4d 41 4b 45 20 43 4f 4f 4b 49 45 20 43 41 4c 4c MAKE COOKIE CALL
6920: 45 44 20 2d 2d 20 6f 6e 20 22 73 65 72 76 6b 65 ED -- on "servke
6930: 79 22 2d 22 2a 63 6f 6f 6b 69 65 2d 73 65 71 6e y"-"*cookie-seqn
6940: 75 6d 2a 29 0a 3b 3b 3b 20 20 20 28 63 6f 6e 63 um*).;;; (conc
6950: 20 6b 65 79 20 22 2d 22 20 2a 63 6f 6f 6b 69 65 key "-" *cookie
6960: 2d 73 65 71 6e 75 6d 2a 29 0a 3b 3b 3b 20 20 20 -seqnum*).;;;
6970: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 64 69 ).;;; .;;; ;; di
6980: 73 70 61 74 63 68 20 6c 6f 63 61 6c 6c 79 20 69 spatch locally i
6990: 66 20 70 6f 73 73 69 62 6c 65 0a 3b 3b 3b 20 3b f possible.;;; ;
69a0: 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 ;.;;; (define (c
69b0: 61 6c 6c 2d 64 65 6c 69 76 65 72 2d 72 65 73 70 all-deliver-resp
69c0: 6f 6e 73 65 20 61 63 66 67 20 69 70 61 64 64 72 onse acfg ipaddr
69d0: 20 70 6f 72 74 20 63 6f 6f 6b 69 65 20 64 61 74 port cookie dat
69e0: 61 29 0a 3b 3b 3b 20 20 20 28 69 66 20 28 61 6e a).;;; (if (an
69f0: 64 20 28 65 71 75 61 6c 3f 20 28 61 72 65 61 2d d (equal? (area-
6a00: 6d 79 61 64 64 72 20 61 63 66 67 29 20 69 70 61 myaddr acfg) ipa
6a10: 64 64 72 29 0a 3b 3b 3b 20 09 20 20 20 28 65 71 ddr).;;; . (eq
6a20: 75 61 6c 3f 20 28 61 72 65 61 2d 70 6f 72 74 20 ual? (area-port
6a30: 20 20 20 20 61 63 66 67 29 20 70 6f 72 74 29 29 acfg) port))
6a40: 0a 3b 3b 3b 20 20 20 20 20 20 20 28 64 65 6c 69 .;;; (deli
6a50: 76 65 72 2d 72 65 73 70 6f 6e 73 65 20 61 63 66 ver-response acf
6a60: 67 20 63 6f 6f 6b 69 65 20 64 61 74 61 29 0a 3b g cookie data).;
6a70: 3b 3b 20 20 20 20 20 20 20 28 28 72 70 63 3a 70 ;; ((rpc:p
6a80: 72 6f 63 65 64 75 72 65 20 27 72 65 73 70 6f 6e rocedure 'respon
6a90: 73 65 20 69 70 61 64 64 72 20 70 6f 72 74 29 20 se ipaddr port)
6aa0: 63 6f 6f 6b 69 65 20 64 61 74 61 29 29 29 0a 3b cookie data))).;
6ab0: 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 ;; .;;; (define
6ac0: 28 64 65 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 (deliver-respons
6ad0: 65 20 61 63 66 67 20 63 6f 6f 6b 69 65 20 64 61 e acfg cookie da
6ae0: 74 61 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 28 ta).;;; (let (
6af0: 28 64 65 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 (deliver-respons
6b00: 65 2d 73 74 61 72 74 20 28 63 75 72 72 65 6e 74 e-start (current
6b10: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 -milliseconds)))
6b20: 0a 3b 3b 3b 20 20 20 20 20 28 74 68 72 65 61 64 .;;; (thread
6b30: 2d 73 74 61 72 74 21 20 28 6d 61 6b 65 2d 74 68 -start! (make-th
6b40: 72 65 61 64 0a 3b 3b 3b 20 09 09 20 20 20 20 28 read.;;; .. (
6b50: 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 09 09 lambda ().;;; ..
6b60: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
6b70: 28 28 74 72 69 65 73 2d 6c 65 66 74 20 35 29 29 ((tries-left 5))
6b80: 0a 3b 3b 3b 20 09 09 09 3b 3b 28 70 72 69 6e 74 .;;; ...;;(print
6b90: 20 22 54 4f 50 20 4f 46 20 44 45 4c 49 56 45 52 "TOP OF DELIVER
6ba0: 5f 52 45 53 50 4f 4e 53 45 20 4c 4f 4f 50 3b 20 _RESPONSE LOOP;
6bb0: 74 72 69 65 73 6c 65 66 74 3d 22 74 72 69 65 73 triesleft="tries
6bc0: 2d 6c 65 66 74 29 0a 3b 3b 3b 20 09 09 09 3b 3b -left).;;; ...;;
6bd0: 28 70 70 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (pp (hash-table-
6be0: 3e 61 6c 69 73 74 20 28 61 72 65 61 2d 63 6f 6f >alist (area-coo
6bf0: 6b 69 65 32 6d 62 6f 78 20 61 63 66 67 29 29 29 kie2mbox acfg)))
6c00: 0a 3b 3b 3b 20 09 09 09 28 6c 65 74 2a 20 28 28 .;;; ...(let* ((
6c10: 6d 62 6f 78 20 28 68 61 73 68 2d 74 61 62 6c 65 mbox (hash-table
6c20: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 61 72 -ref/default (ar
6c30: 65 61 2d 63 6f 6f 6b 69 65 32 6d 62 6f 78 20 61 ea-cookie2mbox a
6c40: 63 66 67 29 20 63 6f 6f 6b 69 65 20 23 66 29 29 cfg) cookie #f))
6c50: 29 0a 3b 3b 3b 20 09 09 09 20 20 28 63 6f 6e 64 ).;;; ... (cond
6c60: 0a 3b 3b 3b 20 09 09 09 20 20 20 28 28 65 71 3f .;;; ... ((eq?
6c70: 20 30 20 74 72 69 65 73 2d 6c 65 66 74 29 0a 3b 0 tries-left).;
6c80: 3b 3b 20 09 09 09 20 20 20 20 28 70 72 69 6e 74 ;; ... (print
6c90: 20 22 75 6c 65 78 3a 64 65 6c 69 76 65 72 2d 72 "ulex:deliver-r
6ca0: 65 73 70 6f 6e 73 65 3a 20 49 20 67 69 76 65 20 esponse: I give
6cb0: 75 70 2e 20 4d 61 69 6c 62 6f 78 20 6e 65 76 65 up. Mailbox neve
6cc0: 72 20 61 70 70 65 61 72 65 64 2e 20 63 6f 6f 6b r appeared. cook
6cd0: 69 65 3d 22 63 6f 6f 6b 69 65 29 0a 3b 3b 3b 20 ie="cookie).;;;
6ce0: 09 09 09 20 20 20 20 29 0a 3b 3b 3b 20 09 09 09 ... ).;;; ...
6cf0: 20 20 20 28 6d 62 6f 78 0a 3b 3b 3b 20 09 09 09 (mbox.;;; ...
6d00: 20 20 20 20 3b 3b 28 70 72 69 6e 74 20 22 67 6f ;;(print "go
6d10: 74 20 6d 62 6f 78 3d 22 6d 62 6f 78 22 20 20 67 t mbox="mbox" g
6d20: 6f 74 20 64 61 74 61 3d 22 64 61 74 61 22 20 20 ot data="data"
6d30: 73 65 6e 64 2e 22 29 0a 3b 3b 3b 20 09 09 09 20 send.").;;; ...
6d40: 20 20 20 28 6d 61 69 6c 62 6f 78 2d 73 65 6e 64 (mailbox-send
6d50: 21 20 6d 62 6f 78 20 64 61 74 61 29 29 0a 3b 3b ! mbox data)).;;
6d60: 3b 20 09 09 09 20 20 20 28 65 6c 73 65 0a 3b 3b ; ... (else.;;
6d70: 3b 20 09 09 09 20 20 20 20 3b 3b 28 70 72 69 6e ; ... ;;(prin
6d80: 74 20 22 6e 6f 20 6d 62 6f 78 20 79 65 74 2e 20 t "no mbox yet.
6d90: 20 6c 6f 6f 6b 20 66 6f 72 20 22 63 6f 6f 6b 69 look for "cooki
6da0: 65 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 28 74 e).;;; ... (t
6db0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 hread-sleep! (/
6dc0: 28 2d 20 36 20 74 72 69 65 73 2d 6c 65 66 74 29 (- 6 tries-left)
6dd0: 20 31 30 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 10)).;;; ...
6de0: 20 28 6c 6f 6f 70 20 28 73 75 62 31 20 74 72 69 (loop (sub1 tri
6df0: 65 73 2d 6c 65 66 74 29 29 29 29 29 29 0a 3b 3b es-left)))))).;;
6e00: 3b 20 09 09 20 20 20 20 20 20 3b 3b 20 28 64 65 ; .. ;; (de
6e10: 62 75 67 2d 70 70 20 28 6c 69 73 74 20 28 63 6f bug-pp (list (co
6e20: 6e 63 20 22 75 6c 65 78 3a 64 65 6c 69 76 65 72 nc "ulex:deliver
6e30: 2d 72 65 73 70 6f 6e 73 65 20 74 6f 6f 6b 20 22 -response took "
6e40: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c (- (current-mil
6e50: 6c 69 73 65 63 6f 6e 64 73 29 20 64 65 6c 69 76 liseconds) deliv
6e60: 65 72 2d 72 65 73 70 6f 6e 73 65 2d 73 74 61 72 er-response-star
6e70: 74 29 20 22 20 6d 73 2c 20 63 6f 6f 6b 69 65 3d t) " ms, cookie=
6e80: 22 20 63 6f 6f 6b 69 65 20 22 20 64 61 74 61 3d " cookie " data=
6e90: 22 29 20 64 61 74 61 29 29 0a 3b 3b 3b 20 09 09 ") data)).;;; ..
6ea0: 20 20 20 20 20 20 28 73 64 62 67 3e 20 22 64 65 (sdbg> "de
6eb0: 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 65 22 20 liver-response"
6ec0: 22 6d 61 69 6c 62 6f 78 2d 73 65 6e 64 22 20 64 "mailbox-send" d
6ed0: 65 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 65 2d eliver-response-
6ee0: 73 74 61 72 74 20 23 66 20 23 66 20 63 6f 6f 6b start #f #f cook
6ef0: 69 65 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 ie).;;; ..
6f00: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 28 63 6f 6e ).;;; .. (con
6f10: 63 20 22 64 65 6c 69 76 65 72 2d 72 65 73 70 6f c "deliver-respo
6f20: 6e 73 65 20 74 68 72 65 61 64 20 66 6f 72 20 63 nse thread for c
6f30: 6f 6f 6b 69 65 3d 22 63 6f 6f 6b 69 65 29 29 29 ookie="cookie)))
6f40: 29 0a 3b 3b 3b 20 20 20 23 74 29 0a 3b 3b 3b 20 ).;;; #t).;;;
6f50: 0a 3b 3b 3b 20 3b 3b 20 61 63 74 69 6f 6e 3a 0a .;;; ;; action:.
6f60: 3b 3b 3b 20 3b 3b 20 20 20 69 6d 6d 65 64 69 61 ;;; ;; immedia
6f70: 74 65 20 2d 20 71 75 69 63 6b 20 61 63 74 69 6f te - quick actio
6f80: 6e 73 2c 20 6e 6f 20 6e 65 65 64 20 74 6f 20 70 ns, no need to p
6f90: 75 74 20 69 6e 20 71 75 65 75 65 73 0a 3b 3b 3b ut in queues.;;;
6fa0: 20 3b 3b 20 20 20 64 62 77 72 69 74 65 20 20 20 ;; dbwrite
6fb0: 2d 20 70 75 74 20 69 6e 20 64 62 77 72 69 74 65 - put in dbwrite
6fc0: 20 71 75 65 75 65 0a 3b 3b 3b 20 3b 3b 20 20 20 queue.;;; ;;
6fd0: 64 62 72 65 61 64 20 20 20 20 2d 20 70 75 74 20 dbread - put
6fe0: 69 6e 20 64 62 72 65 61 64 20 71 75 65 75 65 0a in dbread queue.
6ff0: 3b 3b 3b 20 3b 3b 20 20 20 6f 73 6c 6f 6e 67 20 ;;; ;; oslong
7000: 20 20 20 2d 20 6f 73 20 61 63 74 69 6f 6e 73 2c - os actions,
7010: 20 65 2e 67 2e 20 64 75 2c 20 74 68 61 74 20 63 e.g. du, that c
7020: 6f 75 6c 64 20 74 61 6b 65 20 61 20 6c 6f 6e 67 ould take a long
7030: 20 74 69 6d 65 0a 3b 3b 3b 20 3b 3b 20 20 20 6f time.;;; ;; o
7040: 73 73 68 6f 72 74 20 20 20 2d 20 6f 73 20 61 63 sshort - os ac
7050: 74 69 6f 6e 73 20 74 68 61 74 20 73 68 6f 75 6c tions that shoul
7060: 64 20 62 65 20 71 75 69 63 6b 2c 20 65 2e 67 2e d be quick, e.g.
7070: 20 64 66 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 df.;;; ;;.;;; (
7080: 64 65 66 69 6e 65 20 28 72 65 71 75 65 73 74 20 define (request
7090: 61 63 66 67 20 66 72 6f 6d 2d 69 70 61 64 64 72 acfg from-ipaddr
70a0: 20 66 72 6f 6d 2d 70 6f 72 74 20 73 65 72 76 6b from-port servk
70b0: 65 79 20 61 63 74 69 6f 6e 20 63 6f 6f 6b 69 65 ey action cookie
70c0: 20 66 6e 61 6d 65 20 70 61 72 61 6d 73 29 20 3b fname params) ;
70d0: 3b 20 73 74 64 2d 70 65 65 72 2d 68 61 6e 64 6c ; std-peer-handl
70e0: 65 72 0a 3b 3b 3b 20 20 20 3b 3b 20 4e 4f 54 45 er.;;; ;; NOTE
70f0: 3a 20 55 73 65 20 72 70 63 3a 63 75 72 72 65 6e : Use rpc:curren
7100: 74 2d 70 65 65 72 20 66 6f 72 20 67 65 74 74 69 t-peer for getti
7110: 6e 67 20 72 65 74 75 72 6e 20 61 64 64 72 65 73 ng return addres
7120: 73 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 s.;;; (let* ((
7130: 73 74 64 2d 70 65 65 72 2d 68 61 6e 64 6c 65 72 std-peer-handler
7140: 2d 73 74 61 72 74 20 28 63 75 72 72 65 6e 74 2d -start (current-
7150: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b milliseconds)).;
7160: 3b 3b 20 09 20 3b 3b 20 28 72 61 77 2d 64 61 74 ;; . ;; (raw-dat
7170: 61 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 a
7180: 28 61 6c 69 73 74 2d 72 65 66 20 27 64 61 74 61 (alist-ref 'data
7190: 20 20 20 20 20 64 61 74 29 29 0a 3b 3b 3b 20 09 dat)).;;; .
71a0: 20 28 72 64 61 74 20 20 20 20 20 20 20 20 20 20 (rdat
71b0: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
71c0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
71d0: 0a 3b 3b 3b 20 09 09 09 09 20 20 28 61 72 65 61 .;;; .... (area
71e0: 2d 72 74 61 62 6c 65 20 61 63 66 67 29 20 61 63 -rtable acfg) ac
71f0: 74 69 6f 6e 20 23 66 29 29 20 3b 3b 20 74 68 69 tion #f)) ;; thi
7200: 73 20 6c 6f 6f 6b 73 20 75 70 20 74 68 65 20 73 s looks up the s
7210: 71 6c 20 71 75 65 72 79 20 6f 72 20 6f 74 68 65 ql query or othe
7220: 72 20 64 65 74 61 69 6c 73 20 69 6e 64 65 78 65 r details indexe
7230: 64 20 62 79 20 74 68 65 20 61 63 74 69 6f 6e 0a d by the action.
7240: 3b 3b 3b 20 09 20 28 77 69 74 65 6d 20 20 20 20 ;;; . (witem
7250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
7260: 61 6b 65 2d 77 69 74 65 6d 20 72 69 70 61 64 64 ake-witem ripadd
7270: 72 3a 20 66 72 6f 6d 2d 69 70 61 64 64 72 20 3b r: from-ipaddr ;
7280: 3b 20 72 68 6f 73 74 3a 20 20 20 66 72 6f 6d 2d ; rhost: from-
7290: 68 6f 73 74 20 20 20 0a 3b 3b 3b 20 09 09 09 09 host .;;; ....
72a0: 09 20 20 20 20 20 72 70 6f 72 74 3a 20 20 20 66 . rport: f
72b0: 72 6f 6d 2d 70 6f 72 74 20 20 20 61 63 74 69 6f rom-port actio
72c0: 6e 3a 20 20 61 63 74 69 6f 6e 0a 3b 3b 3b 20 09 n: action.;;; .
72d0: 09 09 09 09 20 20 20 20 20 72 64 61 74 3a 20 20 .... rdat:
72e0: 20 20 72 64 61 74 20 20 20 20 20 20 20 20 63 6f rdat co
72f0: 6f 6b 69 65 3a 20 20 63 6f 6f 6b 69 65 0a 3b 3b okie: cookie.;;
7300: 3b 20 09 09 09 09 09 20 20 20 20 20 73 65 72 76 ; ..... serv
7310: 6b 65 79 3a 20 73 65 72 76 6b 65 79 20 20 20 20 key: servkey
7320: 20 64 61 74 61 3a 20 20 20 20 70 61 72 61 6d 73 data: params
7330: 20 3b 3b 20 54 4f 44 4f 20 2d 20 72 65 6e 61 6d ;; TODO - renam
7340: 65 20 64 61 74 61 20 74 6f 20 70 61 72 61 6d 73 e data to params
7350: 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 20 63 .;;; ..... c
7360: 61 6c 6c 65 72 3a 20 20 28 72 70 63 3a 63 75 72 aller: (rpc:cur
7370: 72 65 6e 74 2d 70 65 65 72 29 29 29 29 0a 3b 3b rent-peer)))).;;
7380: 3b 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ; (if (not (
7390: 65 71 75 61 6c 3f 20 73 65 72 76 6b 65 79 20 28 equal? servkey (
73a0: 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 area-pktid acfg)
73b0: 29 29 0a 3b 3b 3b 20 09 60 28 23 66 20 2e 20 2c )).;;; .`(#f . ,
73c0: 28 63 6f 6e 63 20 22 49 20 64 6f 6e 27 74 20 6b (conc "I don't k
73d0: 6e 6f 77 20 79 6f 75 20 73 65 72 76 6b 65 79 3d now you servkey=
73e0: 22 20 73 65 72 76 6b 65 79 20 22 2c 20 70 6b 74 " servkey ", pkt
73f0: 69 64 3d 22 20 28 61 72 65 61 2d 70 6b 74 69 64 id=" (area-pktid
7400: 20 61 63 66 67 29 29 29 20 3b 3b 20 69 6d 6d 65 acfg))) ;; imme
7410: 64 69 61 74 65 6c 79 20 72 65 74 75 72 6e 20 74 diately return t
7420: 68 69 73 0a 3b 3b 3b 20 09 28 6c 65 74 2a 20 28 his.;;; .(let* (
7430: 28 63 74 79 70 65 20 28 69 66 20 72 64 61 74 20 (ctype (if rdat
7440: 0a 3b 3b 3b 20 09 09 09 20 20 28 63 61 6c 6c 64 .;;; ... (calld
7450: 61 74 2d 63 74 79 70 65 20 72 64 61 74 29 20 3b at-ctype rdat) ;
7460: 3b 20 69 73 20 74 68 69 73 20 6e 65 63 65 73 73 ; is this necess
7470: 61 72 79 3f 20 74 68 65 73 65 20 73 68 6f 75 6c ary? these shoul
7480: 64 20 62 65 20 69 64 65 6e 74 69 63 61 6c 0a 3b d be identical.;
7490: 3b 3b 20 09 09 09 20 20 61 63 74 69 6f 6e 29 29 ;; ... action))
74a0: 29 0a 3b 3b 3b 20 09 20 20 28 73 64 62 67 3e 20 ).;;; . (sdbg>
74b0: 22 73 74 64 2d 70 65 65 72 2d 68 61 6e 64 6c 65 "std-peer-handle
74c0: 72 22 20 22 69 6d 6d 65 64 69 61 74 65 22 20 73 r" "immediate" s
74d0: 74 64 2d 70 65 65 72 2d 68 61 6e 64 6c 65 72 2d td-peer-handler-
74e0: 73 74 61 72 74 20 23 66 20 23 66 29 0a 3b 3b 3b start #f #f).;;;
74f0: 20 09 20 20 28 63 61 73 65 20 63 74 79 70 65 0a . (case ctype.
7500: 3b 3b 3b 20 09 20 20 20 20 3b 3b 20 28 64 62 77 ;;; . ;; (dbw
7510: 72 69 74 65 20 61 63 66 67 20 72 64 61 74 20 28 rite acfg rdat (
7520: 63 6f 6e 73 20 66 72 6f 6d 2d 69 70 61 64 64 72 cons from-ipaddr
7530: 20 66 72 6f 6d 2d 70 6f 72 74 29 20 64 61 74 61 from-port) data
7540: 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 28 66 ))).;;; . ((f
7550: 75 6c 6c 2d 70 69 6e 67 29 20 20 60 28 23 74 20 ull-ping) `(#t
7560: 20 22 61 63 6b 20 74 6f 20 66 75 6c 6c 20 70 69 "ack to full pi
7570: 6e 67 22 20 20 20 20 20 20 20 20 2c 28 77 6f 72 ng" ,(wor
7580: 6b 2d 71 75 65 75 65 2d 61 64 64 20 61 63 66 67 k-queue-add acfg
7590: 20 66 6e 61 6d 65 20 77 69 74 65 6d 29 20 2c 63 fname witem) ,c
75a0: 6f 6f 6b 69 65 29 29 0a 3b 3b 3b 20 09 20 20 20 ookie)).;;; .
75b0: 20 28 28 72 65 73 70 6f 6e 73 65 29 20 20 20 60 ((response) `
75c0: 28 23 74 20 20 22 61 63 6b 20 66 72 6f 6d 20 72 (#t "ack from r
75d0: 65 71 75 65 73 74 6f 72 22 20 20 20 20 20 20 2c equestor" ,
75e0: 28 64 65 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 (deliver-respons
75f0: 65 20 61 63 66 67 20 66 6e 61 6d 65 20 70 61 72 e acfg fname par
7600: 61 6d 73 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 ams))).;;; .
7610: 28 28 64 62 77 72 69 74 65 29 20 20 20 20 60 28 ((dbwrite) `(
7620: 23 74 20 20 22 64 62 20 77 72 69 74 65 20 73 75 #t "db write su
7630: 62 6d 69 74 74 65 64 22 20 20 20 20 20 20 2c 28 bmitted" ,(
7640: 77 6f 72 6b 2d 71 75 65 75 65 2d 61 64 64 20 61 work-queue-add a
7650: 63 66 67 20 66 6e 61 6d 65 20 77 69 74 65 6d 29 cfg fname witem)
7660: 20 2c 63 6f 6f 6b 69 65 29 29 0a 3b 3b 3b 20 09 ,cookie)).;;; .
7670: 20 20 20 20 28 28 64 62 72 65 61 64 29 20 20 20 ((dbread)
7680: 20 20 60 28 23 74 20 20 22 64 62 20 72 65 61 64 `(#t "db read
7690: 20 73 75 62 6d 69 74 74 65 64 22 20 20 20 20 20 submitted"
76a0: 20 20 2c 28 77 6f 72 6b 2d 71 75 65 75 65 2d 61 ,(work-queue-a
76b0: 64 64 20 61 63 66 67 20 66 6e 61 6d 65 20 77 69 dd acfg fname wi
76c0: 74 65 6d 29 20 2c 63 6f 6f 6b 69 65 20 20 29 29 tem) ,cookie ))
76d0: 0a 3b 3b 3b 20 09 20 20 20 20 28 28 64 62 72 77 .;;; . ((dbrw
76e0: 29 20 20 20 20 20 20 20 60 28 23 74 20 20 22 64 ) `(#t "d
76f0: 62 20 72 65 61 64 2f 77 72 69 74 65 20 73 75 62 b read/write sub
7700: 6d 69 74 74 65 64 22 20 2c 63 6f 6f 6b 69 65 29 mitted" ,cookie)
7710: 29 0a 3b 3b 3b 20 09 20 20 20 20 28 28 6f 73 73 ).;;; . ((oss
7720: 68 6f 72 74 29 20 20 20 20 60 28 23 74 20 20 22 hort) `(#t "
7730: 6f 73 20 73 68 6f 72 74 20 73 75 62 6d 69 74 74 os short submitt
7740: 65 64 22 20 20 20 20 20 20 2c 63 6f 6f 6b 69 65 ed" ,cookie
7750: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 28 6f 73 )).;;; . ((os
7760: 6c 6f 6e 67 29 20 20 20 20 20 60 28 23 74 20 20 long) `(#t
7770: 22 6f 73 20 6c 6f 6e 67 20 73 75 62 6d 69 74 74 "os long submitt
7780: 65 64 22 20 20 20 20 20 20 20 2c 63 6f 6f 6b 69 ed" ,cooki
7790: 65 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 65 6c e)).;;; . (el
77a0: 73 65 20 20 20 20 20 20 20 20 20 60 28 23 66 20 se `(#f
77b0: 20 22 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 61 "unrecognised a
77c0: 63 74 69 6f 6e 22 20 20 20 20 20 2c 63 74 79 70 ction" ,ctyp
77d0: 65 29 29 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b e))))))).;;; .;;
77e0: 3b 20 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 74 ; ;; Call this t
77f0: 6f 20 73 74 61 72 74 20 74 68 65 20 61 63 74 75 o start the actu
7800: 61 6c 20 73 65 72 76 65 72 0a 3b 3b 3b 20 3b 3b al server.;;; ;;
7810: 0a 3b 3b 3b 20 3b 3b 20 73 74 61 72 74 5f 73 65 .;;; ;; start_se
7820: 72 76 65 72 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 rver.;;; ;;.;;;
7830: 3b 3b 20 20 20 6d 6f 64 65 3a 20 27 0a 3b 3b 3b ;; mode: '.;;;
7840: 20 3b 3b 20 20 20 68 61 6e 64 6c 65 72 3a 20 70 ;; handler: p
7850: 72 6f 63 20 77 68 69 63 68 20 74 61 6b 65 73 20 roc which takes
7860: 70 6b 74 72 65 63 69 65 76 65 64 20 61 73 20 61 pktrecieved as a
7870: 72 67 75 6d 65 6e 74 0a 3b 3b 3b 20 3b 3b 0a 3b rgument.;;; ;;.;
7880: 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 ;; .;;; (define
7890: 28 73 74 61 72 74 2d 73 65 72 76 65 72 20 61 63 (start-server ac
78a0: 66 67 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 fg).;;; (let*
78b0: 28 28 63 6f 6e 6e 20 28 66 69 6e 64 2d 66 72 65 ((conn (find-fre
78c0: 65 2d 70 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 e-port-and-open
78d0: 61 63 66 67 29 29 0a 3b 3b 3b 20 09 20 28 70 6f acfg)).;;; . (po
78e0: 72 74 20 28 61 72 65 61 2d 70 6f 72 74 20 61 63 rt (area-port ac
78f0: 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 fg))).;;; (r
7900: 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 pc:publish-proce
7910: 64 75 72 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 dure!.;;; '
7920: 64 65 6c 69 73 74 2d 64 62 0a 3b 3b 3b 20 20 20 delist-db.;;;
7930: 20 20 20 28 6c 61 6d 62 64 61 20 28 66 6e 61 6d (lambda (fnam
7940: 65 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 68 e).;;; (h
7950: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
7960: 21 20 28 61 72 65 61 2d 64 62 73 20 61 63 66 67 ! (area-dbs acfg
7970: 29 20 66 6e 61 6d 65 29 29 29 0a 3b 3b 3b 20 20 ) fname))).;;;
7980: 20 20 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d (rpc:publish-
7990: 70 72 6f 63 65 64 75 72 65 21 0a 3b 3b 3b 20 20 procedure!.;;;
79a0: 20 20 20 20 27 63 61 6c 6c 69 6e 67 2d 61 64 64 'calling-add
79b0: 72 0a 3b 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 r.;;; (lamb
79c0: 64 61 20 28 29 0a 3b 3b 3b 20 20 20 20 20 20 20 da ().;;;
79d0: 20 28 72 70 63 3a 63 75 72 72 65 6e 74 2d 70 65 (rpc:current-pe
79e0: 65 72 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 er))).;;; (r
79f0: 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 pc:publish-proce
7a00: 64 75 72 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 dure!.;;; '
7a10: 70 69 6e 67 0a 3b 3b 3b 20 20 20 20 20 20 28 6c ping.;;; (l
7a20: 61 6d 62 64 61 20 28 29 28 72 65 61 6c 2d 70 69 ambda ()(real-pi
7a30: 6e 67 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 20 ng acfg))).;;;
7a40: 20 20 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d (rpc:publish-
7a50: 70 72 6f 63 65 64 75 72 65 21 0a 3b 3b 3b 20 20 procedure!.;;;
7a60: 20 20 20 20 27 72 65 71 75 65 73 74 0a 3b 3b 3b 'request.;;;
7a70: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 66 (lambda (f
7a80: 72 6f 6d 2d 61 64 64 72 20 66 72 6f 6d 2d 70 6f rom-addr from-po
7a90: 72 74 20 73 65 72 76 6b 65 79 20 61 63 74 69 6f rt servkey actio
7aa0: 6e 20 63 6f 6f 6b 69 65 20 64 62 6e 61 6d 65 20 n cookie dbname
7ab0: 70 61 72 61 6d 73 29 0a 3b 3b 3b 20 20 20 20 20 params).;;;
7ac0: 20 20 20 28 72 65 71 75 65 73 74 20 61 63 66 67 (request acfg
7ad0: 20 66 72 6f 6d 2d 61 64 64 72 20 66 72 6f 6d 2d from-addr from-
7ae0: 70 6f 72 74 20 73 65 72 76 6b 65 79 20 61 63 74 port servkey act
7af0: 69 6f 6e 20 63 6f 6f 6b 69 65 20 64 62 6e 61 6d ion cookie dbnam
7b00: 65 20 70 61 72 61 6d 73 29 29 29 0a 3b 3b 3b 20 e params))).;;;
7b10: 20 20 20 20 28 72 70 63 3a 70 75 62 6c 69 73 68 (rpc:publish
7b20: 2d 70 72 6f 63 65 64 75 72 65 21 0a 3b 3b 3b 20 -procedure!.;;;
7b30: 20 20 20 20 20 27 72 65 73 70 6f 6e 73 65 0a 3b 'response.;
7b40: 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ;; (lambda
7b50: 28 63 6f 6f 6b 69 65 20 72 65 73 2d 64 61 74 29 (cookie res-dat)
7b60: 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 64 65 6c .;;; (del
7b70: 69 76 65 72 2d 72 65 73 70 6f 6e 73 65 20 61 63 iver-response ac
7b80: 66 67 20 63 6f 6f 6b 69 65 20 72 65 73 2d 64 61 fg cookie res-da
7b90: 74 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 61 72 t))).;;; (ar
7ba0: 65 61 2d 72 65 61 64 79 2d 73 65 74 21 20 61 63 ea-ready-set! ac
7bb0: 66 67 20 23 74 29 0a 3b 3b 3b 20 20 20 20 20 28 fg #t).;;; (
7bc0: 61 72 65 61 2d 63 6f 6e 6e 2d 73 65 74 21 20 61 area-conn-set! a
7bd0: 63 66 67 20 63 6f 6e 6e 29 0a 3b 3b 3b 20 20 20 cfg conn).;;;
7be0: 20 20 28 28 72 70 63 3a 6d 61 6b 65 2d 73 65 72 ((rpc:make-ser
7bf0: 76 65 72 20 63 6f 6e 6e 29 20 23 66 29 29 29 3b ver conn) #f)));
7c00: 3b 20 28 28 74 63 70 2d 6c 69 73 74 65 6e 20 28 ; ((tcp-listen (
7c10: 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 rpc:default-serv
7c20: 65 72 2d 70 6f 72 74 29 29 20 23 74 29 0a 3b 3b er-port)) #t).;;
7c30: 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 ; .;;; .;;; (def
7c40: 69 6e 65 20 28 6c 61 75 6e 63 68 20 61 63 66 67 ine (launch acfg
7c50: 29 20 3b 3b 20 20 23 21 6f 70 74 69 6f 6e 61 6c ) ;; #!optional
7c60: 20 28 70 72 6f 63 20 73 74 64 2d 70 65 65 72 2d (proc std-peer-
7c70: 68 61 6e 64 6c 65 72 29 29 0a 3b 3b 3b 20 20 20 handler)).;;;
7c80: 28 70 72 69 6e 74 20 22 73 74 61 72 74 69 6e 67 (print "starting
7c90: 20 6c 61 75 6e 63 68 22 29 0a 3b 3b 3b 20 20 20 launch").;;;
7ca0: 28 75 70 64 61 74 65 2d 6b 6e 6f 77 6e 2d 73 65 (update-known-se
7cb0: 72 76 65 72 73 20 61 63 66 67 29 20 3b 3b 20 67 rvers acfg) ;; g
7cc0: 6f 74 74 61 20 64 6f 20 74 68 69 73 20 6f 6e 20 otta do this on
7cd0: 65 76 65 72 79 20 73 74 61 72 74 20 28 74 68 75 every start (thu
7ce0: 73 20 77 68 79 20 6c 69 6d 69 74 20 6e 75 6d 62 s why limit numb
7cf0: 65 72 20 6f 66 20 70 75 62 6c 69 63 69 73 65 64 er of publicised
7d00: 20 73 65 72 76 65 72 73 29 0a 3b 3b 3b 20 20 20 servers).;;;
7d10: 23 3b 28 6c 65 74 20 28 28 6f 72 69 67 69 6e 61 #;(let ((origina
7d20: 6c 2d 68 61 6e 64 6c 65 72 20 28 63 75 72 72 65 l-handler (curre
7d30: 6e 74 2d 65 78 63 65 70 74 69 6f 6e 2d 68 61 6e nt-exception-han
7d40: 64 6c 65 72 29 29 29 20 3b 3b 20 69 73 20 74 68 dler))) ;; is th
7d50: 0a 3b 3b 3b 20 20 20 20 20 28 6c 61 6d 62 64 61 .;;; (lambda
7d60: 20 28 65 78 63 65 70 74 69 6f 6e 29 0a 3b 3b 3b (exception).;;;
7d70: 20 20 20 20 20 20 20 28 73 65 72 76 65 72 2d 65 (server-e
7d80: 78 69 74 2d 70 72 6f 63 65 64 75 72 65 29 0a 3b xit-procedure).;
7d90: 3b 3b 20 20 20 20 20 20 20 28 6f 72 69 67 69 6e ;; (origin
7da0: 61 6c 2d 68 61 6e 64 6c 65 72 20 65 78 63 65 70 al-handler excep
7db0: 74 69 6f 6e 29 29 29 0a 3b 3b 3b 20 20 20 28 6f tion))).;;; (o
7dc0: 6e 2d 65 78 69 74 20 28 6c 61 6d 62 64 61 20 28 n-exit (lambda (
7dd0: 29 0a 3b 3b 3b 20 09 20 20 20 20 20 28 73 68 75 ).;;; . (shu
7de0: 74 64 6f 77 6e 20 61 63 66 67 29 29 29 20 3b 3b tdown acfg))) ;;
7df0: 20 28 66 69 6e 61 6c 69 7a 65 2d 61 6c 6c 2d 64 (finalize-all-d
7e00: 62 2d 68 61 6e 64 6c 65 73 20 61 63 66 67 29 29 b-handles acfg))
7e10: 29 0a 3b 3b 3b 20 20 20 3b 3b 20 73 65 74 20 75 ).;;; ;; set u
7e20: 70 20 74 68 65 20 72 70 63 20 68 61 6e 64 6c 65 p the rpc handle
7e30: 72 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 r.;;; (let* ((
7e40: 74 68 31 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 th1 (make-threa
7e50: 64 0a 3b 3b 3b 20 09 09 28 6c 61 6d 62 64 61 20 d.;;; ..(lambda
7e60: 28 29 28 73 74 61 72 74 2d 73 65 72 76 65 72 20 ()(start-server
7e70: 61 63 66 67 29 29 0a 3b 3b 3b 20 09 09 22 73 65 acfg)).;;; .."se
7e80: 72 76 65 72 20 74 68 72 65 61 64 22 29 29 0a 3b rver thread")).;
7e90: 3b 3b 20 09 20 28 74 68 32 20 20 20 28 6d 61 6b ;; . (th2 (mak
7ea0: 65 2d 74 68 72 65 61 64 0a 3b 3b 3b 20 09 09 20 e-thread.;;; ..
7eb0: 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 09 (lambda ().;;; .
7ec0: 09 20 20 20 28 70 72 69 6e 74 20 22 74 68 32 20 . (print "th2
7ed0: 73 74 61 72 74 69 6e 67 22 29 0a 3b 3b 3b 20 09 starting").;;; .
7ee0: 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 . (let loop ()
7ef0: 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 77 6f 72 .;;; .. (wor
7f00: 6b 2d 71 75 65 75 65 2d 70 72 6f 63 65 73 73 6f k-queue-processo
7f10: 72 20 61 63 66 67 29 0a 3b 3b 3b 20 09 09 20 20 r acfg).;;; ..
7f20: 20 20 20 28 70 72 69 6e 74 20 22 77 6f 72 6b 2d (print "work-
7f30: 71 75 65 75 65 2d 70 72 6f 63 65 73 73 6f 72 20 queue-processor
7f40: 63 72 61 73 68 65 64 21 22 29 0a 3b 3b 3b 20 09 crashed!").;;; .
7f50: 09 20 20 20 20 20 28 6c 6f 6f 70 29 29 29 0a 3b . (loop))).;
7f60: 3b 3b 20 09 09 20 22 77 6f 72 6b 20 71 75 65 75 ;; .. "work queu
7f70: 65 20 74 68 72 65 61 64 22 29 29 29 0a 3b 3b 3b e thread"))).;;;
7f80: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 (thread-sta
7f90: 72 74 21 20 74 68 31 29 0a 3b 3b 3b 20 20 20 20 rt! th1).;;;
7fa0: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
7fb0: 74 68 32 29 0a 3b 3b 3b 20 20 20 20 20 28 6c 65 th2).;;; (le
7fc0: 74 20 6c 6f 6f 70 20 28 29 0a 3b 3b 3b 20 20 20 t loop ().;;;
7fd0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
7fe0: 70 21 20 30 2e 30 32 35 29 0a 3b 3b 3b 20 20 20 p! 0.025).;;;
7ff0: 20 20 20 20 28 69 66 20 28 61 72 65 61 2d 72 65 (if (area-re
8000: 61 64 79 20 61 63 66 67 29 0a 3b 3b 3b 20 09 20 ady acfg).;;; .
8010: 20 23 74 0a 3b 3b 3b 20 09 20 20 28 6c 6f 6f 70 #t.;;; . (loop
8020: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 61 ))).;;; ;; a
8030: 74 74 65 6d 70 74 20 74 6f 20 66 69 78 20 6d 79 ttempt to fix my
8040: 20 61 64 64 72 65 73 73 0a 3b 3b 3b 20 20 20 20 address.;;;
8050: 20 28 6c 65 74 2a 20 28 28 61 6c 6c 2d 61 64 64 (let* ((all-add
8060: 72 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 2d 73 r (get-all-ips-s
8070: 6f 72 74 65 64 29 29 29 09 20 20 20 20 20 3b 3b orted))). ;;
8080: 20 63 6f 75 6c 64 20 75 73 65 20 28 74 63 70 2d could use (tcp-
8090: 61 64 64 72 65 73 73 65 73 20 63 6f 6e 6e 29 3f addresses conn)?
80a0: 0a 3b 3b 3b 20 20 20 20 20 20 20 28 6c 65 74 20 .;;; (let
80b0: 6c 6f 6f 70 20 28 28 72 65 6d 2d 61 64 64 72 73 loop ((rem-addrs
80c0: 20 61 6c 6c 2d 61 64 64 72 29 29 0a 3b 3b 3b 20 all-addr)).;;;
80d0: 09 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 2d .(if (null? rem-
80e0: 61 64 64 72 73 29 0a 3b 3b 3b 20 09 20 20 20 20 addrs).;;; .
80f0: 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 20 20 (begin.;;; .
8100: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
8110: 20 46 61 69 6c 65 64 20 74 6f 20 66 69 67 75 72 Failed to figur
8120: 65 20 6f 75 74 20 74 68 65 20 69 70 20 61 64 64 e out the ip add
8130: 72 65 73 73 20 6f 66 20 6d 79 73 65 6c 66 20 61 ress of myself a
8140: 73 20 61 20 73 65 72 76 65 72 2e 20 47 69 76 69 s a server. Givi
8150: 6e 67 20 75 70 2e 22 29 0a 3b 3b 3b 20 09 20 20 ng up.").;;; .
8160: 20 20 20 20 28 65 78 69 74 20 31 29 29 20 3b 3b (exit 1)) ;;
8170: 20 42 55 47 20 43 68 61 6e 67 65 6d 65 20 74 6f BUG Changeme to
8180: 20 72 61 69 73 69 6e 67 20 61 6e 20 65 78 63 65 raising an exce
8190: 70 74 69 6f 6e 0a 3b 3b 3b 20 09 09 0a 3b 3b 3b ption.;;; ...;;;
81a0: 20 09 20 20 20 20 28 6c 65 74 2a 20 28 28 61 64 . (let* ((ad
81b0: 64 72 20 20 20 20 20 20 28 63 61 72 20 72 65 6d dr (car rem
81c0: 2d 61 64 64 72 73 29 29 0a 3b 3b 3b 20 09 09 20 -addrs)).;;; ..
81d0: 20 20 28 67 6f 6f 64 2d 61 64 64 72 20 28 68 61 (good-addr (ha
81e0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
81f0: 3b 3b 3b 20 09 09 09 09 20 20 65 78 6e 0a 3b 3b ;;; .... exn.;;
8200: 3b 20 09 09 09 09 20 20 23 66 0a 3b 3b 3b 20 09 ; .... #f.;;; .
8210: 09 09 09 28 28 72 70 63 3a 70 72 6f 63 65 64 75 ...((rpc:procedu
8220: 72 65 20 27 63 61 6c 6c 69 6e 67 2d 61 64 64 72 re 'calling-addr
8230: 20 61 64 64 72 20 28 61 72 65 61 2d 70 6f 72 74 addr (area-port
8240: 20 61 63 66 67 29 29 29 29 29 29 0a 3b 3b 3b 20 acfg)))))).;;;
8250: 09 20 20 20 20 20 20 28 69 66 20 67 6f 6f 64 2d . (if good-
8260: 61 64 64 72 0a 3b 3b 3b 20 09 09 20 20 28 62 65 addr.;;; .. (be
8270: 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 20 28 70 gin.;;; .. (p
8280: 72 69 6e 74 20 22 47 6f 74 20 67 6f 6f 64 2d 61 rint "Got good-a
8290: 64 64 72 20 6f 66 20 22 20 67 6f 6f 64 2d 61 64 ddr of " good-ad
82a0: 64 72 29 0a 3b 3b 3b 20 09 09 20 20 20 20 28 61 dr).;;; .. (a
82b0: 72 65 61 2d 6d 79 61 64 64 72 2d 73 65 74 21 20 rea-myaddr-set!
82c0: 61 63 66 67 20 67 6f 6f 64 2d 61 64 64 72 29 29 acfg good-addr))
82d0: 0a 3b 3b 3b 20 09 09 20 20 28 6c 6f 6f 70 20 28 .;;; .. (loop (
82e0: 63 64 72 20 72 65 6d 2d 61 64 64 72 73 29 29 29 cdr rem-addrs)))
82f0: 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 65 )))).;;; (re
8300: 67 69 73 74 65 72 2d 6e 6f 64 65 20 61 63 66 67 gister-node acfg
8310: 20 28 61 72 65 61 2d 6d 79 61 64 64 72 20 61 63 (area-myaddr ac
8320: 66 67 29 28 61 72 65 61 2d 70 6f 72 74 20 61 63 fg)(area-port ac
8330: 66 67 29 29 0a 3b 3b 3b 20 20 20 20 20 28 70 72 fg)).;;; (pr
8340: 69 6e 74 20 22 49 4e 46 4f 3a 20 53 65 72 76 65 int "INFO: Serve
8350: 72 20 73 74 61 72 74 65 64 20 6f 6e 20 22 20 28 r started on " (
8360: 61 72 65 61 2d 6d 79 61 64 64 72 20 61 63 66 67 area-myaddr acfg
8370: 29 20 22 3a 22 20 28 61 72 65 61 2d 70 6f 72 74 ) ":" (area-port
8380: 20 61 63 66 67 29 29 0a 3b 3b 3b 20 20 20 20 20 acfg)).;;;
8390: 3b 3b 20 28 75 70 64 61 74 65 2d 6b 6e 6f 77 6e ;; (update-known
83a0: 2d 73 65 72 76 65 72 73 20 61 63 66 67 29 20 3b -servers acfg) ;
83b0: 3b 20 67 6f 74 74 61 20 64 6f 20 74 68 69 73 20 ; gotta do this
83c0: 6f 6e 20 65 76 65 72 79 20 73 74 61 72 74 20 28 on every start (
83d0: 74 68 75 73 20 77 68 79 20 6c 69 6d 69 74 20 6e thus why limit n
83e0: 75 6d 62 65 72 20 6f 66 20 70 75 62 6c 69 63 69 umber of publici
83f0: 73 65 64 20 73 65 72 76 65 72 73 29 0a 3b 3b 3b sed servers).;;;
8400: 20 20 20 20 20 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b )).;;; .;;;
8410: 20 28 64 65 66 69 6e 65 20 28 63 6c 65 61 72 2d (define (clear-
8420: 73 65 72 76 65 72 2d 70 6b 74 20 61 63 66 67 29 server-pkt acfg)
8430: 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 28 28 70 6b .;;; (let ((pk
8440: 74 66 20 28 61 72 65 61 2d 70 6b 74 66 69 6c 65 tf (area-pktfile
8450: 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 acfg))).;;;
8460: 20 28 69 66 20 70 6b 74 66 20 28 64 65 6c 65 74 (if pktf (delet
8470: 65 2d 66 69 6c 65 2a 20 70 6b 74 66 29 29 29 29 e-file* pktf))))
8480: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e .;;; .;;; (defin
8490: 65 20 28 73 68 75 74 64 6f 77 6e 20 61 63 66 67 e (shutdown acfg
84a0: 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 28 3b 3b ).;;; (let (;;
84b0: 28 63 6f 6e 6e 20 28 61 72 65 61 2d 63 6f 6e 6e (conn (area-conn
84c0: 20 20 20 20 61 63 66 67 29 29 0a 3b 3b 3b 20 09 acfg)).;;; .
84d0: 28 70 6b 74 66 20 28 61 72 65 61 2d 70 6b 74 66 (pktf (area-pktf
84e0: 69 6c 65 20 61 63 66 67 29 29 0a 3b 3b 3b 20 09 ile acfg)).;;; .
84f0: 28 70 6f 72 74 20 28 61 72 65 61 2d 70 6f 72 74 (port (area-port
8500: 20 20 20 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 acfg))).;;;
8510: 20 20 20 20 28 69 66 20 70 6b 74 66 20 28 64 65 (if pktf (de
8520: 6c 65 74 65 2d 66 69 6c 65 2a 20 70 6b 74 66 29 lete-file* pktf)
8530: 29 0a 3b 3b 3b 20 20 20 20 20 28 73 65 6e 64 2d ).;;; (send-
8540: 61 6c 6c 20 22 69 6d 73 68 75 74 74 69 6e 67 64 all "imshuttingd
8550: 6f 77 6e 22 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b own").;;; ;;
8560: 20 28 72 70 63 3a 63 6c 6f 73 65 2d 61 6c 6c 2d (rpc:close-all-
8570: 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 20 3b 3b connections!) ;;
8580: 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 69 66 20 74 don't know if t
8590: 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 his is actually
85a0: 6e 65 65 64 65 64 0a 3b 3b 3b 20 20 20 20 20 28 needed.;;; (
85b0: 66 69 6e 61 6c 69 7a 65 2d 61 6c 6c 2d 64 62 2d finalize-all-db-
85c0: 68 61 6e 64 6c 65 73 20 61 63 66 67 29 29 29 0a handles acfg))).
85d0: 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 ;;; .;;; (define
85e0: 20 28 73 65 6e 64 2d 61 6c 6c 20 6d 73 67 29 0a (send-all msg).
85f0: 3b 3b 3b 20 20 20 23 66 29 0a 3b 3b 3b 20 0a 3b ;;; #f).;;; .;
8600: 3b 3b 20 3b 3b 20 67 69 76 65 6e 20 61 20 61 72 ;; ;; given a ar
8610: 65 61 20 72 65 63 6f 72 64 20 6c 6f 6f 6b 20 75 ea record look u
8620: 70 20 61 6c 6c 20 74 68 65 20 70 61 63 6b 65 74 p all the packet
8630: 73 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 s.;;; ;;.;;; (de
8640: 66 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 73 65 fine (get-all-se
8650: 72 76 65 72 2d 70 6b 74 73 20 61 63 66 67 29 0a rver-pkts acfg).
8660: 3b 3b 3b 20 20 20 28 6c 65 74 20 28 28 61 6c 6c ;;; (let ((all
8670: 2d 70 6b 74 2d 66 69 6c 65 73 20 28 67 6c 6f 62 -pkt-files (glob
8680: 20 28 63 6f 6e 63 20 28 61 72 65 61 2d 70 6b 74 (conc (area-pkt
8690: 73 64 69 72 20 61 63 66 67 29 20 22 2f 2a 2e 70 sdir acfg) "/*.p
86a0: 6b 74 22 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 kt")))).;;;
86b0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 6b (map (lambda (pk
86c0: 74 2d 66 69 6c 65 29 0a 3b 3b 3b 20 09 20 20 20 t-file).;;; .
86d0: 28 72 65 61 64 2d 70 6b 74 2d 3e 61 6c 69 73 74 (read-pkt->alist
86e0: 20 70 6b 74 2d 66 69 6c 65 20 70 6b 74 73 70 65 pkt-file pktspe
86f0: 63 3a 20 2a 70 6b 74 73 70 65 63 2a 29 29 0a 3b c: *pktspec*)).;
8700: 3b 3b 20 09 20 61 6c 6c 2d 70 6b 74 2d 66 69 6c ;; . all-pkt-fil
8710: 65 73 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 23 es))).;;; .;;; #
8720: 3b 28 28 5a 20 2e 20 22 39 61 30 32 31 32 33 30 ;((Z . "9a021230
8730: 32 32 39 35 61 31 39 36 31 30 64 35 37 39 36 66 2295a19610d5796f
8740: 63 65 30 33 37 30 66 61 31 33 30 37 35 38 65 39 ce0370fa130758e9
8750: 22 29 0a 3b 3b 3b 20 20 20 28 70 6f 72 74 20 2e ").;;; (port .
8760: 20 22 33 34 38 32 37 22 29 0a 3b 3b 3b 20 20 20 "34827").;;;
8770: 28 70 69 64 20 2e 20 22 32 38 37 34 38 22 29 0a (pid . "28748").
8780: 3b 3b 3b 20 20 20 28 68 6f 73 74 6e 61 6d 65 20 ;;; (hostname
8790: 2e 20 22 7a 65 75 73 22 29 0a 3b 3b 3b 20 20 20 . "zeus").;;;
87a0: 28 54 20 2e 20 22 73 65 72 76 65 72 22 29 0a 3b (T . "server").;
87b0: 3b 3b 20 20 20 28 44 20 2e 20 22 31 35 34 39 34 ;; (D . "15494
87c0: 32 37 30 33 32 2e 30 22 29 29 0a 3b 3b 3b 20 0a 27032.0")).;;; .
87d0: 3b 3b 3b 20 23 3b 28 64 65 66 69 6e 65 20 28 67 ;;; #;(define (g
87e0: 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 et-my-best-addre
87f0: 73 73 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 28 ss).;;; (let (
8800: 28 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 (all-my-addresse
8810: 73 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 29 s (get-all-ips))
8820: 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 3e 6c 69 ) ;; (vector->li
8830: 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 st (hostinfo-add
8840: 72 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d 65 resses (hostname
8850: 2d 3e 68 6f 73 74 69 6e 66 6f 20 28 67 65 74 2d ->hostinfo (get-
8860: 68 6f 73 74 2d 6e 61 6d 65 29 29 29 29 29 29 0a host-name)))))).
8870: 3b 3b 3b 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b ;;; (cond.;;
8880: 3b 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 61 ; ((null? a
8890: 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 ll-my-addresses)
88a0: 0a 3b 3b 3b 20 20 20 20 20 20 20 28 67 65 74 2d .;;; (get-
88b0: 68 6f 73 74 2d 6e 61 6d 65 29 29 20 20 20 20 20 host-name))
88c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88e0: 20 20 20 20 20 3b 3b 20 6e 6f 20 69 6e 74 65 72 ;; no inter
88f0: 66 61 63 65 73 3f 0a 3b 3b 3b 20 20 20 20 20 20 faces?.;;;
8900: 28 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 61 6c ((eq? (length al
8910: 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 20 l-my-addresses)
8920: 31 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 69 70 1).;;; (ip
8930: 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 20 61 6c ->string (car al
8940: 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 29 l-my-addresses))
8950: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
8960: 20 20 20 20 20 20 20 3b 3b 20 6f 6e 6c 79 20 6f ;; only o
8970: 6e 65 20 74 6f 20 63 68 6f 6f 73 65 20 66 72 6f ne to choose fro
8980: 6d 2c 20 6a 75 73 74 20 67 6f 20 77 69 74 68 20 m, just go with
8990: 69 74 0a 3b 3b 3b 20 20 20 20 20 20 28 65 6c 73 it.;;; (els
89a0: 65 20 0a 3b 3b 3b 20 20 20 20 20 20 20 28 69 70 e .;;; (ip
89b0: 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 20 28 66 ->string (car (f
89c0: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
89d0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
89e0: 20 20 20 20 20 20 20 3b 3b 20 74 61 6b 65 20 61 ;; take a
89f0: 6e 79 20 62 75 74 20 31 32 37 2e 0a 3b 3b 3b 20 ny but 127..;;;
8a00: 09 09 09 09 20 28 6e 6f 74 20 28 65 71 3f 20 28 .... (not (eq? (
8a10: 75 38 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 u8vector-ref x 0
8a20: 29 20 31 32 37 29 29 29 0a 3b 3b 3b 20 09 09 09 ) 127))).;;; ...
8a30: 20 20 20 20 20 20 20 61 6c 6c 2d 6d 79 2d 61 64 all-my-ad
8a40: 64 72 65 73 73 65 73 29 29 29 29 29 29 29 0a 3b dresses))))))).;
8a50: 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 77 68 6f 61 6d ;; .;;; ;; whoam
8a60: 69 3f 20 49 20 61 6d 20 6d 79 20 70 6b 74 0a 3b i? I am my pkt.;
8a70: 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e ;; ;;.;;; (defin
8a80: 65 20 28 77 68 6f 61 6d 69 3f 20 61 63 66 67 29 e (whoami? acfg)
8a90: 0a 3b 3b 3b 20 20 20 28 68 61 73 68 2d 74 61 62 .;;; (hash-tab
8aa0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
8ab0: 61 72 65 61 2d 68 6f 73 74 73 20 61 63 66 67 29 area-hosts acfg)
8ac0: 28 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 (area-pktid acfg
8ad0: 29 20 23 66 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 ) #f)).;;; .;;;
8ae0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
8af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b20: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 ========.;;; ;;
8b30: 22 43 6c 69 65 6e 74 20 73 69 64 65 22 20 6f 70 "Client side" op
8b40: 65 72 61 74 69 6f 6e 73 0a 3b 3b 3b 20 3b 3b 3d erations.;;; ;;=
8b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b90: 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 =====.;;; .;;; (
8ba0: 64 65 66 69 6e 65 20 28 73 61 66 65 2d 63 61 6c define (safe-cal
8bb0: 6c 20 63 61 6c 6c 2d 6b 65 79 20 68 6f 73 74 20 l call-key host
8bc0: 70 6f 72 74 20 2e 20 70 61 72 61 6d 73 29 0a 3b port . params).;
8bd0: 3b 3b 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 ;; (handle-exc
8be0: 65 70 74 69 6f 6e 73 0a 3b 3b 3b 20 20 20 20 65 eptions.;;; e
8bf0: 78 6e 0a 3b 3b 3b 20 20 20 20 28 62 65 67 69 6e xn.;;; (begin
8c00: 0a 3b 3b 3b 20 20 20 20 20 20 28 70 72 69 6e 74 .;;; (print
8c10: 20 22 43 61 6c 6c 20 22 20 63 61 6c 6c 2d 6b 65 "Call " call-ke
8c20: 79 20 22 20 74 6f 20 22 20 68 6f 73 74 20 22 3a y " to " host ":
8c30: 22 20 70 6f 72 74 20 22 20 66 61 69 6c 65 64 22 " port " failed"
8c40: 29 0a 3b 3b 3b 20 20 20 20 20 20 23 66 29 0a 3b ).;;; #f).;
8c50: 3b 3b 20 20 20 20 28 61 70 70 6c 79 20 28 72 70 ;; (apply (rp
8c60: 63 3a 70 72 6f 63 65 64 75 72 65 20 63 61 6c 6c c:procedure call
8c70: 2d 6b 65 79 20 68 6f 73 74 20 70 6f 72 74 29 20 -key host port)
8c80: 70 61 72 61 6d 73 29 29 29 0a 3b 3b 3b 20 0a 3b params))).;;; .;
8c90: 3b 3b 20 3b 3b 20 3b 3b 20 63 6f 6e 76 65 72 74 ;; ;; ;; convert
8ca0: 20 74 6f 2f 66 72 6f 6d 20 73 74 72 69 6e 67 20 to/from string
8cb0: 2f 20 73 65 78 70 72 0a 3b 3b 3b 20 3b 3b 20 0a / sexpr.;;; ;; .
8cc0: 3b 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;; ;; (define (
8cd0: 73 74 72 69 6e 67 2d 3e 73 65 78 70 72 20 73 74 string->sexpr st
8ce0: 72 29 0a 3b 3b 3b 20 3b 3b 20 20 20 28 69 66 20 r).;;; ;; (if
8cf0: 28 73 74 72 69 6e 67 3f 20 73 74 72 29 0a 3b 3b (string? str).;;
8d00: 3b 20 3b 3b 20 20 20 20 20 20 20 28 77 69 74 68 ; ;; (with
8d10: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 73 74 72 69 -input-from-stri
8d20: 6e 67 20 73 74 72 20 72 65 61 64 29 0a 3b 3b 3b ng str read).;;;
8d30: 20 3b 3b 20 20 20 20 20 20 20 73 74 72 29 29 0a ;; str)).
8d40: 3b 3b 3b 20 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 28 ;;; ;; .;;; ;; (
8d50: 64 65 66 69 6e 65 20 28 73 65 78 70 72 2d 3e 73 define (sexpr->s
8d60: 74 72 69 6e 67 20 73 29 0a 3b 3b 3b 20 3b 3b 20 tring s).;;; ;;
8d70: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
8d80: 6f 2d 73 74 72 69 6e 67 20 28 6c 61 6d 62 64 61 o-string (lambda
8d90: 20 28 29 28 77 72 69 74 65 20 73 29 29 29 29 0a ()(write s)))).
8da0: 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 69 73 20 74 ;;; .;;; ;; is t
8db0: 68 65 20 73 65 72 76 65 72 20 61 6c 69 76 65 3f he server alive?
8dc0: 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 .;;; ;;.;;; (def
8dd0: 69 6e 65 20 28 70 69 6e 67 20 61 63 66 67 20 68 ine (ping acfg h
8de0: 6f 73 74 20 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 ost port).;;;
8df0: 28 6c 65 74 2a 20 28 28 6d 79 61 64 64 72 20 20 (let* ((myaddr
8e00: 20 20 20 28 61 72 65 61 2d 6d 79 61 64 64 72 20 (area-myaddr
8e10: 61 63 66 67 29 29 0a 3b 3b 3b 20 09 20 28 6d 79 acfg)).;;; . (my
8e20: 70 6f 72 74 20 20 20 20 20 28 61 72 65 61 2d 70 port (area-p
8e30: 6f 72 74 20 20 20 61 63 66 67 29 29 0a 3b 3b 3b ort acfg)).;;;
8e40: 20 09 20 28 73 74 61 72 74 2d 74 69 6d 65 20 28 . (start-time (
8e50: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
8e60: 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 28 72 65 onds)).;;; . (re
8e70: 73 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e s (if (an
8e80: 64 20 28 65 71 75 61 6c 3f 20 6d 79 61 64 64 72 d (equal? myaddr
8e90: 20 68 6f 73 74 29 0a 3b 3b 3b 20 09 09 09 20 20 host).;;; ...
8ea0: 20 20 20 20 28 65 71 75 61 6c 3f 20 6d 79 70 6f (equal? mypo
8eb0: 72 74 20 70 6f 72 74 29 29 0a 3b 3b 3b 20 09 09 rt port)).;;; ..
8ec0: 09 20 28 72 65 61 6c 2d 70 69 6e 67 20 61 63 66 . (real-ping acf
8ed0: 67 29 0a 3b 3b 3b 20 09 09 09 20 28 28 72 70 63 g).;;; ... ((rpc
8ee0: 3a 70 72 6f 63 65 64 75 72 65 20 27 70 69 6e 67 :procedure 'ping
8ef0: 20 68 6f 73 74 20 70 6f 72 74 29 29 29 29 29 0a host port))))).
8f00: 3b 3b 3b 20 20 20 20 20 28 63 6f 6e 73 20 28 2d ;;; (cons (-
8f10: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
8f20: 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 econds) start-ti
8f30: 6d 65 29 0a 3b 3b 3b 20 09 20 20 72 65 73 29 29 me).;;; . res))
8f40: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 72 65 ).;;; .;;; ;; re
8f50: 74 75 72 6e 73 20 28 20 69 70 61 64 64 72 20 70 turns ( ipaddr p
8f60: 6f 72 74 20 61 6c 69 73 74 2d 66 6e 61 6d 65 3d ort alist-fname=
8f70: 3e 72 61 6e 64 6e 75 6d 20 29 0a 3b 3b 3b 20 28 >randnum ).;;; (
8f80: 64 65 66 69 6e 65 20 28 72 65 61 6c 2d 70 69 6e define (real-pin
8f90: 67 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 60 28 g acfg).;;; `(
8fa0: 2c 28 61 72 65 61 2d 6d 79 61 64 64 72 20 61 63 ,(area-myaddr ac
8fb0: 66 67 29 20 2c 28 61 72 65 61 2d 70 6f 72 74 20 fg) ,(area-port
8fc0: 61 63 66 67 29 20 2c 28 67 65 74 2d 68 6f 73 74 acfg) ,(get-host
8fd0: 2d 73 74 61 74 73 20 61 63 66 67 29 29 29 0a 3b -stats acfg))).;
8fe0: 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 69 73 20 74 68 ;; .;;; ;; is th
8ff0: 65 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 41 e server alive A
9000: 4e 44 20 74 68 65 20 71 75 65 75 65 73 20 70 72 ND the queues pr
9010: 6f 63 65 73 73 69 6e 67 3f 0a 3b 3b 3b 20 3b 3b ocessing?.;;; ;;
9020: 0a 3b 3b 3b 20 23 3b 28 64 65 66 69 6e 65 20 28 .;;; #;(define (
9030: 66 75 6c 6c 2d 70 69 6e 67 20 61 63 66 67 20 73 full-ping acfg s
9040: 65 72 76 70 6b 74 29 0a 3b 3b 3b 20 20 20 28 6c ervpkt).;;; (l
9050: 65 74 2a 20 28 28 73 74 61 72 74 2d 74 69 6d 65 et* ((start-time
9060: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
9070: 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 28 econds)).;;; . (
9080: 72 65 73 20 20 20 20 20 20 20 20 28 73 65 6e 64 res (send
9090: 2d 6d 65 73 73 61 67 65 20 61 63 66 67 20 73 65 -message acfg se
90a0: 72 76 70 6b 74 20 27 28 66 75 6c 6c 2d 70 69 6e rvpkt '(full-pin
90b0: 67 29 20 27 66 75 6c 6c 2d 70 69 6e 67 29 29 29 g) 'full-ping)))
90c0: 0a 3b 3b 3b 20 20 20 20 20 28 63 6f 6e 73 20 28 .;;; (cons (
90d0: 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 - (current-milli
90e0: 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 seconds) start-t
90f0: 69 6d 65 29 0a 3b 3b 3b 20 09 20 20 72 65 73 29 ime).;;; . res)
9100: 29 29 20 3b 3b 20 28 65 71 75 61 6c 3f 20 72 65 )) ;; (equal? re
9110: 73 20 22 67 6f 74 20 70 69 6e 67 22 29 29 29 29 s "got ping"))))
9120: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b .;;; .;;; .;;; ;
9130: 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 70 6b ; look up all pk
9140: 74 73 20 61 6e 64 20 67 65 74 20 74 68 65 20 73 ts and get the s
9150: 65 72 76 65 72 20 69 64 20 28 74 68 65 20 68 61 erver id (the ha
9160: 73 68 29 2c 20 70 6f 72 74 2c 20 68 6f 73 74 2f sh), port, host/
9170: 69 70 0a 3b 3b 3b 20 3b 3b 20 73 74 6f 72 65 20 ip.;;; ;; store
9180: 74 68 69 73 20 69 6e 66 6f 20 69 6e 20 61 63 66 this info in acf
9190: 67 0a 3b 3b 3b 20 3b 3b 20 72 65 74 75 72 6e 20 g.;;; ;; return
91a0: 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 72 65 the number of re
91b0: 73 70 6f 6e 73 69 76 65 20 73 65 72 76 65 72 73 sponsive servers
91c0: 20 66 6f 75 6e 64 0a 3b 3b 3b 20 3b 3b 0a 3b 3b found.;;; ;;.;;
91d0: 3b 20 3b 3b 20 44 4f 20 4e 4f 54 20 56 45 52 49 ; ;; DO NOT VERI
91e0: 46 59 20 54 48 41 54 20 54 48 45 20 53 45 52 56 FY THAT THE SERV
91f0: 45 52 20 49 53 20 41 4c 49 56 45 20 48 45 52 45 ER IS ALIVE HERE
9200: 2e 20 54 68 69 73 20 69 73 20 63 61 6c 6c 65 64 . This is called
9210: 20 61 74 20 74 69 6d 65 73 20 77 68 65 72 65 20 at times where
9220: 74 68 65 20 63 75 72 72 65 6e 74 20 73 65 72 76 the current serv
9230: 65 72 20 69 73 20 6e 6f 74 20 79 65 74 20 61 6c er is not yet al
9240: 69 76 65 20 61 6e 64 20 63 61 6e 6e 6f 74 20 70 ive and cannot p
9250: 69 6e 67 20 69 74 73 65 6c 66 0a 3b 3b 3b 20 3b ing itself.;;; ;
9260: 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 75 ;.;;; (define (u
9270: 70 64 61 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 pdate-known-serv
9280: 65 72 73 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 ers acfg).;;;
9290: 3b 3b 20 72 65 61 64 6c 6c 20 61 6c 6c 20 70 6b ;; readll all pk
92a0: 74 73 0a 3b 3b 3b 20 20 20 3b 3b 20 66 6f 72 65 ts.;;; ;; fore
92b0: 61 63 68 20 70 6b 74 3b 20 69 66 20 69 74 20 69 ach pkt; if it i
92c0: 73 6e 27 74 20 6d 65 20 70 69 6e 67 20 74 68 65 sn't me ping the
92d0: 20 73 65 72 76 65 72 3b 20 69 66 20 61 6c 69 76 server; if aliv
92e0: 65 2c 20 61 64 64 20 74 6f 20 68 6f 73 74 73 20 e, add to hosts
92f0: 68 61 73 68 2c 20 65 6c 73 65 20 72 6d 20 74 68 hash, else rm th
9300: 65 20 70 6b 74 0a 3b 3b 3b 20 20 20 28 6c 65 74 e pkt.;;; (let
9310: 2a 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 * ((start-time (
9320: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
9330: 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 28 61 6c onds)).;;; . (al
9340: 6c 2d 70 6b 74 73 20 20 28 64 65 6c 65 74 65 2d l-pkts (delete-
9350: 64 75 70 6c 69 63 61 74 65 73 0a 3b 3b 3b 20 09 duplicates.;;; .
9360: 09 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 67 . (append (g
9370: 65 74 2d 61 6c 6c 2d 73 65 72 76 65 72 2d 70 6b et-all-server-pk
9380: 74 73 20 61 63 66 67 29 0a 3b 3b 3b 20 09 09 09 ts acfg).;;; ...
9390: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
93a0: 2d 76 61 6c 75 65 73 20 28 61 72 65 61 2d 68 6f -values (area-ho
93b0: 73 74 73 20 61 63 66 67 29 29 29 29 29 0a 3b 3b sts acfg))))).;;
93c0: 3b 20 09 20 28 68 6f 73 74 73 68 61 73 68 20 28 ; . (hostshash (
93d0: 61 72 65 61 2d 68 6f 73 74 73 20 61 63 66 67 29 area-hosts acfg)
93e0: 29 0a 3b 3b 3b 20 09 20 28 6d 79 2d 69 64 20 20 ).;;; . (my-id
93f0: 20 20 20 28 61 72 65 61 2d 70 6b 74 69 64 20 61 (area-pktid a
9400: 63 66 67 29 29 0a 3b 3b 3b 20 09 20 28 70 6b 74 cfg)).;;; . (pkt
9410: 73 64 69 72 20 20 20 28 61 72 65 61 2d 70 6b 74 sdir (area-pkt
9420: 73 64 69 72 20 61 63 66 67 29 29 20 3b 3b 20 6e sdir acfg)) ;; n
9430: 65 65 64 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 eeded to remove
9440: 70 6b 74 73 20 66 72 6f 6d 20 6e 6f 6e 2d 72 65 pkts from non-re
9450: 73 70 6f 6e 73 69 76 65 20 73 65 72 76 65 72 73 sponsive servers
9460: 0a 3b 3b 3b 20 09 20 28 6e 75 6d 73 72 76 73 20 .;;; . (numsrvs
9470: 20 20 30 29 0a 3b 3b 3b 20 09 20 28 64 65 6c 70 0).;;; . (delp
9480: 6b 74 20 20 20 20 28 6c 61 6d 62 64 61 20 28 70 kt (lambda (p
9490: 6b 74 73 64 69 72 20 73 69 64 29 0a 3b 3b 3b 20 ktsdir sid).;;;
94a0: 09 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 .. (print "
94b0: 63 6c 65 61 72 69 6e 67 20 6f 75 74 20 73 65 72 clearing out ser
94c0: 76 65 72 20 22 20 73 69 64 29 0a 3b 3b 3b 20 09 ver " sid).;;; .
94d0: 09 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 . (delete-f
94e0: 69 6c 65 2a 20 28 63 6f 6e 63 20 70 6b 74 73 64 ile* (conc pktsd
94f0: 69 72 20 22 2f 22 20 73 69 64 20 22 2e 70 6b 74 ir "/" sid ".pkt
9500: 22 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 ")).;;; ..
9510: 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 (hash-table-dele
9520: 74 65 21 20 68 6f 73 74 73 68 61 73 68 20 73 69 te! hostshash si
9530: 64 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 61 d)))).;;; (a
9540: 72 65 61 2d 6c 61 73 74 2d 73 72 76 75 70 2d 73 rea-last-srvup-s
9550: 65 74 21 20 61 63 66 67 20 28 63 75 72 72 65 6e et! acfg (curren
9560: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 t-seconds)).;;;
9570: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b (for-each.;;
9580: 3b 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 ; (lambda (
9590: 73 65 72 76 70 6b 74 29 0a 3b 3b 3b 20 20 20 20 servpkt).;;;
95a0: 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 73 (if (list? s
95b0: 65 72 76 70 6b 74 29 0a 3b 3b 3b 20 09 20 20 20 ervpkt).;;; .
95c0: 3b 3b 20 28 70 70 20 73 65 72 76 70 6b 74 29 0a ;; (pp servpkt).
95d0: 3b 3b 3b 20 09 20 20 20 28 6c 65 74 2a 20 28 28 ;;; . (let* ((
95e0: 73 68 6f 73 74 20 28 61 6c 69 73 74 2d 72 65 66 shost (alist-ref
95f0: 20 27 69 70 61 64 64 72 20 73 65 72 76 70 6b 74 'ipaddr servpkt
9600: 29 29 0a 3b 3b 3b 20 09 09 20 20 28 73 70 6f 72 )).;;; .. (spor
9610: 74 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 t (any->number (
9620: 61 6c 69 73 74 2d 72 65 66 20 27 70 6f 72 74 20 alist-ref 'port
9630: 73 65 72 76 70 6b 74 29 29 29 0a 3b 3b 3b 20 09 servpkt))).;;; .
9640: 09 20 20 28 72 65 73 20 20 20 28 68 61 6e 64 6c . (res (handl
9650: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 3b e-exceptions.;;;
9660: 20 09 09 09 20 20 65 78 6e 0a 3b 3b 3b 20 09 09 ... exn.;;; ..
9670: 09 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 . (begin.;;; ..
9680: 09 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 . ;; (print "
9690: 49 4e 46 4f 3a 20 62 61 64 20 73 65 72 76 65 72 INFO: bad server
96a0: 20 6f 6e 20 22 20 73 68 6f 73 74 20 22 3a 22 20 on " shost ":"
96b0: 73 70 6f 72 74 29 0a 3b 3b 3b 20 09 09 09 20 20 sport).;;; ...
96c0: 20 20 23 66 29 0a 3b 3b 3b 20 09 09 09 20 20 28 #f).;;; ... (
96d0: 70 69 6e 67 20 61 63 66 67 20 73 68 6f 73 74 20 ping acfg shost
96e0: 73 70 6f 72 74 29 29 29 0a 3b 3b 3b 20 09 09 20 sport))).;;; ..
96f0: 20 28 73 69 64 20 20 20 28 61 6c 69 73 74 2d 72 (sid (alist-r
9700: 65 66 20 27 5a 20 73 65 72 76 70 6b 74 29 29 20 ef 'Z servpkt))
9710: 3b 3b 20 5a 20 63 6f 64 65 20 69 73 20 6f 75 72 ;; Z code is our
9720: 20 6e 61 6d 65 20 66 6f 72 20 74 68 65 20 73 65 name for the se
9730: 72 76 65 72 0a 3b 3b 3b 20 09 09 20 20 28 75 72 rver.;;; .. (ur
9740: 6c 20 20 20 28 63 6f 6e 63 20 73 68 6f 73 74 20 l (conc shost
9750: 22 3a 22 20 73 70 6f 72 74 29 29 0a 3b 3b 3b 20 ":" sport)).;;;
9760: 09 09 20 20 29 0a 3b 3b 3b 20 09 20 20 20 20 20 .. ).;;; .
9770: 23 3b 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 72 #;(if (or (not r
9780: 65 73 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 es).;;; .. (
9790: 6e 75 6c 6c 3f 20 72 65 73 29 29 0a 3b 3b 3b 20 null? res)).;;;
97a0: 09 09 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 .. (begin.;;; ..
97b0: 20 20 20 28 70 72 69 6e 74 20 22 53 54 52 41 4e (print "STRAN
97c0: 47 45 3a 20 70 69 6e 67 20 6f 66 20 22 20 75 72 GE: ping of " ur
97d0: 6c 20 22 20 67 61 76 65 20 22 20 72 65 73 29 29 l " gave " res))
97e0: 29 0a 3b 3b 3b 20 09 20 20 20 20 20 0a 3b 3b 3b ).;;; . .;;;
97f0: 20 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 . ;; (print
9800: 20 22 47 6f 74 20 22 20 72 65 73 20 22 20 66 72 "Got " res " fr
9810: 6f 6d 20 22 20 73 68 6f 73 74 20 22 3a 22 20 73 om " shost ":" s
9820: 70 6f 72 74 29 0a 3b 3b 3b 20 09 20 20 20 20 20 port).;;; .
9830: 28 6d 61 74 63 68 20 72 65 73 0a 3b 3b 3b 20 09 (match res.;;; .
9840: 09 20 20 20 20 28 28 71 64 75 72 61 74 69 6f 6e . ((qduration
9850: 20 2e 20 70 61 79 6c 6f 61 64 29 0a 3b 3b 3b 20 . payload).;;;
9860: 09 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 .. ;; (print
9870: 20 22 53 65 72 76 65 72 20 70 6b 74 3a 22 20 28 "Server pkt:" (
9880: 61 6c 69 73 74 2d 72 65 66 20 27 69 70 61 64 64 alist-ref 'ipadd
9890: 72 20 73 65 72 76 70 6b 74 29 20 22 3a 22 20 28 r servpkt) ":" (
98a0: 61 6c 69 73 74 2d 72 65 66 20 27 70 6f 72 74 20 alist-ref 'port
98b0: 73 65 72 76 70 6b 74 29 0a 3b 3b 3b 20 09 09 20 servpkt).;;; ..
98c0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 69 ;; (i
98d0: 66 20 70 61 79 6c 6f 61 64 0a 3b 3b 3b 20 09 09 f payload.;;; ..
98e0: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 ;;
98f0: 20 20 20 22 53 75 63 63 65 73 73 22 20 22 46 61 "Success" "Fa
9900: 69 6c 22 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 il")).;;; ..
9910: 20 28 6d 61 74 63 68 20 70 61 79 6c 6f 61 64 0a (match payload.
9920: 3b 3b 3b 20 09 09 09 20 20 20 20 28 28 68 6f 73 ;;; ... ((hos
9930: 74 20 70 6f 72 74 20 73 74 61 74 73 29 0a 3b 3b t port stats).;;
9940: 3b 20 09 09 09 20 20 20 20 20 3b 3b 20 28 70 72 ; ... ;; (pr
9950: 69 6e 74 20 22 46 72 6f 6d 20 22 20 68 6f 73 74 int "From " host
9960: 20 22 3a 22 20 70 6f 72 74 20 22 20 67 6f 74 20 ":" port " got
9970: 73 74 61 74 73 3a 20 22 20 73 74 61 74 73 29 0a stats: " stats).
9980: 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 69 66 20 ;;; ... (if
9990: 28 61 6e 64 20 68 6f 73 74 20 70 6f 72 74 20 73 (and host port s
99a0: 74 61 74 73 29 0a 3b 3b 3b 20 09 09 09 09 20 28 tats).;;; .... (
99b0: 6c 65 74 20 28 28 75 72 6c 20 28 63 6f 6e 63 20 let ((url (conc
99c0: 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 29 29 29 host ":" port)))
99d0: 0a 3b 3b 3b 20 09 09 09 09 20 20 20 28 68 61 73 .;;; .... (has
99e0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 6f 73 h-table-set! hos
99f0: 74 73 68 61 73 68 20 73 69 64 20 73 65 72 76 70 tshash sid servp
9a00: 6b 74 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 3b kt).;;; .... ;
9a10: 3b 20 73 74 6f 72 65 20 62 61 73 65 64 20 6f 6e ; store based on
9a20: 20 68 6f 73 74 3a 70 6f 72 74 0a 3b 3b 3b 20 09 host:port.;;; .
9a30: 09 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ... (hash-tabl
9a40: 65 2d 73 65 74 21 20 28 61 72 65 61 2d 68 6f 73 e-set! (area-hos
9a50: 74 73 74 61 74 73 20 61 63 66 67 29 20 73 69 64 tstats acfg) sid
9a60: 20 73 74 61 74 73 29 29 0a 3b 3b 3b 20 09 09 09 stats)).;;; ...
9a70: 09 20 28 70 72 69 6e 74 20 22 6d 69 73 73 69 6e . (print "missin
9a80: 67 20 64 61 74 61 20 66 72 6f 6d 20 74 68 65 20 g data from the
9a90: 73 65 72 76 65 72 2c 20 6e 6f 74 20 73 75 72 65 server, not sure
9aa0: 20 77 68 61 74 20 74 68 61 74 20 6d 65 61 6e 73 what that means
9ab0: 21 22 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 !")).;;; ...
9ac0: 20 28 73 65 74 21 20 6e 75 6d 73 72 76 73 20 28 (set! numsrvs (
9ad0: 2b 20 6e 75 6d 73 72 76 73 20 31 29 29 29 0a 3b + numsrvs 1))).;
9ae0: 3b 3b 20 09 09 09 20 20 20 20 28 23 66 0a 3b 3b ;; ... (#f.;;
9af0: 3b 20 09 09 09 20 20 20 20 20 28 70 72 69 6e 74 ; ... (print
9b00: 20 22 52 65 6d 6f 76 69 6e 67 20 70 6b 74 20 22 "Removing pkt "
9b10: 20 73 69 64 20 22 20 64 75 65 20 74 6f 20 23 66 sid " due to #f
9b20: 20 66 72 6f 6d 20 73 65 72 76 65 72 20 6f 72 20 from server or
9b30: 66 61 69 6c 65 64 20 70 69 6e 67 22 29 0a 3b 3b failed ping").;;
9b40: 3b 20 09 09 09 20 20 20 20 20 28 64 65 6c 70 6b ; ... (delpk
9b50: 74 20 70 6b 74 73 64 69 72 20 73 69 64 29 29 0a t pktsdir sid)).
9b60: 3b 3b 3b 20 09 09 09 20 20 20 20 28 65 6c 73 65 ;;; ... (else
9b70: 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 70 72 .;;; ... (pr
9b80: 69 6e 74 20 22 47 6f 74 20 22 29 28 70 70 20 72 int "Got ")(pp r
9b90: 65 73 29 28 70 72 69 6e 74 20 22 20 66 72 6f 6d es)(print " from
9ba0: 20 73 65 72 76 65 72 20 22 29 28 70 70 20 73 65 server ")(pp se
9bb0: 72 76 70 6b 74 29 20 22 20 62 75 74 20 72 65 73 rvpkt) " but res
9bc0: 70 6f 6e 73 65 20 64 69 64 20 6e 6f 74 20 6d 61 ponse did not ma
9bd0: 74 63 68 20 28 23 66 2f 23 74 20 2e 20 6d 73 67 tch (#f/#t . msg
9be0: 29 22 29 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 )"))).;;; ..
9bf0: 28 65 6c 73 65 0a 3b 3b 3b 20 09 09 20 20 20 20 (else.;;; ..
9c00: 20 3b 3b 20 68 65 72 65 20 77 65 20 64 65 6c 65 ;; here we dele
9c10: 74 65 20 74 68 65 20 70 6b 74 20 2d 20 63 61 6e te the pkt - can
9c20: 27 74 20 72 65 61 63 68 20 74 68 65 20 73 65 72 't reach the ser
9c30: 76 65 72 2c 20 72 65 6d 6f 76 65 20 69 74 0a 3b ver, remove it.;
9c40: 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 68 6f 77 ;; .. ;; how
9c50: 65 76 65 72 20 74 68 69 73 20 6c 6f 67 69 63 20 ever this logic
9c60: 69 73 20 69 6e 61 64 65 71 75 61 74 65 2e 20 77 is inadequate. w
9c70: 65 20 73 68 6f 75 6c 64 20 6d 61 72 6b 20 74 68 e should mark th
9c80: 65 20 73 65 72 76 65 72 20 61 73 20 63 68 65 63 e server as chec
9c90: 6b 65 64 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b ked.;;; .. ;
9ca0: 3b 20 61 6e 64 20 6e 6f 74 20 67 6f 6f 64 2c 20 ; and not good,
9cb0: 69 66 20 69 74 20 68 61 70 70 65 6e 73 20 61 20 if it happens a
9cc0: 73 65 63 6f 6e 64 20 74 69 6d 65 20 2d 20 74 68 second time - th
9cd0: 65 6e 20 72 65 6d 6f 76 65 20 74 68 65 20 70 6b en remove the pk
9ce0: 74 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 t.;;; .. ;;
9cf0: 6f 72 20 73 6f 6d 65 74 68 69 6e 67 20 73 69 6d or something sim
9d00: 69 6c 61 72 2e 20 49 2e 65 2e 20 64 6f 6e 27 74 ilar. I.e. don't
9d10: 20 62 65 20 74 6f 6f 20 71 75 69 63 6b 20 74 6f be too quick to
9d20: 20 61 73 73 75 6d 65 20 74 68 65 20 73 65 72 76 assume the serv
9d30: 65 72 20 69 73 20 77 65 64 67 65 64 20 6f 72 20 er is wedged or
9d40: 64 65 61 64 0a 3b 3b 3b 20 09 09 20 20 20 20 20 dead.;;; ..
9d50: 3b 3b 20 63 6f 75 6c 64 20 62 65 20 69 74 20 69 ;; could be it i
9d60: 73 20 73 69 6d 70 6c 79 20 74 6f 6f 20 62 75 73 s simply too bus
9d70: 79 20 74 6f 20 72 65 70 6c 79 0a 3b 3b 3b 20 09 y to reply.;;; .
9d80: 09 20 20 20 20 20 28 6c 65 74 20 28 28 62 61 64 . (let ((bad
9d90: 2d 70 69 6e 67 73 20 28 68 61 73 68 2d 74 61 62 -pings (hash-tab
9da0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
9db0: 61 72 65 61 2d 68 65 61 6c 74 68 20 61 63 66 67 area-health acfg
9dc0: 29 20 75 72 6c 20 30 29 29 29 0a 3b 3b 3b 20 09 ) url 0))).;;; .
9dd0: 09 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 62 . (if (> b
9de0: 61 64 2d 70 69 6e 67 73 20 31 29 20 3b 3b 20 74 ad-pings 1) ;; t
9df0: 77 6f 20 62 61 64 20 70 69 6e 67 73 20 2d 20 72 wo bad pings - r
9e00: 65 6d 6f 76 65 20 70 6b 74 0a 3b 3b 3b 20 09 09 emove pkt.;;; ..
9e10: 09 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 . (begin.;;; .
9e20: 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 49 .. (print "I
9e30: 4e 46 4f 3a 20 22 20 62 61 64 2d 70 69 6e 67 73 NFO: " bad-pings
9e40: 20 22 20 62 61 64 20 72 65 73 70 6f 6e 73 65 73 " bad responses
9e50: 20 66 72 6f 6d 20 22 20 75 72 6c 20 22 2c 20 64 from " url ", d
9e60: 65 6c 65 74 69 6e 67 20 70 6b 74 20 22 20 73 69 eleting pkt " si
9e70: 64 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 d).;;; ... (
9e80: 64 65 6c 70 6b 74 20 70 6b 74 73 64 69 72 20 73 delpkt pktsdir s
9e90: 69 64 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 28 id)).;;; ... (
9ea0: 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 09 20 20 20 begin.;;; ...
9eb0: 20 20 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a 20 (print "INFO:
9ec0: 22 20 62 61 64 2d 70 69 6e 67 73 20 22 20 62 61 " bad-pings " ba
9ed0: 64 20 72 65 73 70 6f 6e 73 65 73 20 66 72 6f 6d d responses from
9ee0: 20 22 20 73 68 6f 73 74 20 22 3a 22 20 73 70 6f " shost ":" spo
9ef0: 72 74 20 22 20 6e 6f 74 20 64 65 6c 65 74 69 6e rt " not deletin
9f00: 67 20 70 6b 74 20 79 65 74 22 29 0a 3b 3b 3b 20 g pkt yet").;;;
9f10: 09 09 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 ... (hash-ta
9f20: 62 6c 65 2d 73 65 74 21 20 28 61 72 65 61 2d 68 ble-set! (area-h
9f30: 65 61 6c 74 68 20 61 63 66 67 29 0a 3b 3b 3b 20 ealth acfg).;;;
9f40: 09 09 09 09 09 20 20 20 20 20 20 75 72 6c 0a 3b ..... url.;
9f50: 3b 3b 20 09 09 09 09 09 20 20 20 20 20 20 28 2b ;; ..... (+
9f60: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
9f70: 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d 68 /default (area-h
9f80: 65 61 6c 74 68 20 61 63 66 67 29 20 75 72 6c 20 ealth acfg) url
9f90: 30 29 20 31 29 29 0a 3b 3b 3b 20 09 09 09 20 20 0) 1)).;;; ...
9fa0: 20 20 20 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 )).;;; ..
9fb0: 20 20 20 29 29 29 29 0a 3b 3b 3b 20 09 20 20 20 )))).;;; .
9fc0: 3b 3b 20 73 65 72 76 70 6b 74 20 69 73 20 6e 6f ;; servpkt is no
9fd0: 74 20 61 63 74 75 61 6c 6c 79 20 61 20 70 6b 74 t actually a pkt
9fe0: 3f 0a 3b 3b 3b 20 09 20 20 20 28 62 65 67 69 6e ?.;;; . (begin
9ff0: 0a 3b 3b 3b 20 09 20 20 20 20 20 28 70 72 69 6e .;;; . (prin
a000: 74 20 22 42 61 64 20 70 6b 74 20 22 20 73 65 72 t "Bad pkt " ser
a010: 76 70 6b 74 29 29 29 29 0a 3b 3b 3b 20 20 20 20 vpkt)))).;;;
a020: 20 20 61 6c 6c 2d 70 6b 74 73 29 0a 3b 3b 3b 20 all-pkts).;;;
a030: 20 20 20 20 28 73 64 62 67 3e 20 22 75 70 64 61 (sdbg> "upda
a040: 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 te-known-servers
a050: 22 20 22 65 6e 64 22 20 73 74 61 72 74 2d 74 69 " "end" start-ti
a060: 6d 65 20 23 66 20 23 66 20 22 20 66 6f 75 6e 64 me #f #f " found
a070: 20 22 20 6e 75 6d 73 72 76 73 0a 3b 3b 3b 20 09 " numsrvs.;;; .
a080: 20 20 20 22 20 73 65 72 76 65 72 73 2c 20 70 6b " servers, pk
a090: 74 73 3a 20 22 20 28 6d 61 70 20 28 6c 61 6d 62 ts: " (map (lamb
a0a0: 64 61 20 28 70 29 0a 3b 3b 3b 20 09 09 09 09 20 da (p).;;; ....
a0b0: 20 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 (alist-ref '
a0c0: 5a 20 70 29 29 0a 3b 3b 3b 20 09 09 09 09 20 20 Z p)).;;; ....
a0d0: 20 61 6c 6c 2d 70 6b 74 73 29 29 0a 3b 3b 3b 20 all-pkts)).;;;
a0e0: 20 20 20 20 6e 75 6d 73 72 76 73 29 29 0a 3b 3b numsrvs)).;;
a0f0: 3b 20 0a 3b 3b 3b 20 28 64 65 66 73 74 72 75 63 ; .;;; (defstruc
a100: 74 20 73 72 76 73 74 61 74 0a 3b 3b 3b 20 20 20 t srvstat.;;;
a110: 28 6e 75 6d 66 69 6c 65 73 20 30 29 20 20 20 3b (numfiles 0) ;
a120: 3b 20 6e 75 6d 62 65 72 20 6f 66 20 64 62 20 66 ; number of db f
a130: 69 6c 65 73 20 68 61 6e 64 6c 65 64 20 62 79 20 iles handled by
a140: 74 68 69 73 20 73 65 72 76 65 72 20 2d 20 73 75 this server - su
a150: 62 74 72 61 63 74 20 31 20 66 6f 72 20 74 68 65 btract 1 for the
a160: 20 64 62 20 62 65 69 6e 67 20 63 75 72 72 65 6e db being curren
a170: 74 6c 79 20 6c 6f 6f 6b 65 64 20 61 74 0a 3b 3b tly looked at.;;
a180: 3b 20 20 20 28 72 61 6e 64 6e 75 6d 20 20 23 66 ; (randnum #f
a190: 29 20 20 3b 3b 20 74 69 65 20 62 72 65 61 6b 65 ) ;; tie breake
a1a0: 72 20 6e 75 6d 62 65 72 20 61 73 73 69 67 6e 65 r number assigne
a1b0: 64 20 74 6f 20 62 79 20 74 68 65 20 73 65 72 76 d to by the serv
a1c0: 65 72 20 69 74 73 65 6c 66 20 2d 20 61 70 70 6c er itself - appl
a1d0: 69 65 73 20 6f 6e 6c 79 20 74 6f 20 74 68 65 20 ies only to the
a1e0: 64 62 20 75 6e 64 65 72 20 63 6f 6e 73 69 64 65 db under conside
a1f0: 72 61 74 69 6f 6e 0a 3b 3b 3b 20 20 20 28 70 6b ration.;;; (pk
a200: 74 20 20 20 20 20 20 23 66 29 29 20 3b 3b 20 74 t #f)) ;; t
a210: 68 65 20 73 65 72 76 65 72 20 70 6b 74 0a 3b 3b he server pkt.;;
a220: 3b 20 0a 3b 3b 3b 20 3b 3b 28 64 65 66 69 6e 65 ; .;;; ;;(define
a230: 20 28 73 72 76 2d 3e 73 72 76 73 74 61 74 20 73 (srv->srvstat s
a240: 72 76 70 6b 74 29 0a 3b 3b 3b 20 20 20 0a 3b 3b rvpkt).;;; .;;
a250: 3b 20 3b 3b 20 47 65 74 20 74 68 65 20 73 65 72 ; ;; Get the ser
a260: 76 65 72 20 62 65 73 74 20 66 6f 72 20 67 69 76 ver best for giv
a270: 65 6e 20 64 62 6e 61 6d 65 20 61 6e 64 20 6b 65 en dbname and ke
a280: 79 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 y.;;; ;;.;;; ;;
a290: 20 20 4e 4f 54 45 3a 20 6b 65 79 20 69 73 20 6e NOTE: key is n
a2a0: 6f 74 20 63 75 72 72 65 6e 74 6c 79 20 75 73 65 ot currently use
a2b0: 64 2e 20 54 68 65 20 6b 65 79 20 70 6f 69 6e 74 d. The key point
a2c0: 73 20 74 6f 20 74 68 65 20 6b 69 6e 64 20 6f 66 s to the kind of
a2d0: 20 71 75 65 72 79 2c 20 74 68 69 73 20 6d 61 79 query, this may
a2e0: 20 62 65 20 75 73 65 66 75 6c 20 66 6f 72 20 64 be useful for d
a2f0: 69 72 65 63 74 69 6e 67 20 72 65 61 64 2d 6f 6e irecting read-on
a300: 6c 79 20 71 75 65 72 69 65 73 2e 0a 3b 3b 3b 20 ly queries..;;;
a310: 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;.;;; (define (
a320: 67 65 74 2d 62 65 73 74 2d 73 65 72 76 65 72 20 get-best-server
a330: 61 63 66 67 20 64 62 6e 61 6d 65 20 6b 65 79 29 acfg dbname key)
a340: 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 3b 3b .;;; (let* (;;
a350: 20 28 73 65 72 76 65 72 73 20 28 68 61 73 68 2d (servers (hash-
a360: 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 28 61 72 table-values (ar
a370: 65 61 2d 68 6f 73 74 73 20 61 63 66 67 29 29 29 ea-hosts acfg)))
a380: 0a 3b 3b 3b 20 09 20 28 73 65 72 76 65 72 73 20 .;;; . (servers
a390: 20 20 20 20 28 61 72 65 61 2d 68 6f 73 74 73 20 (area-hosts
a3a0: 61 63 66 67 29 29 0a 3b 3b 3b 20 09 20 28 73 6b acfg)).;;; . (sk
a3b0: 65 79 73 20 20 20 20 20 20 20 28 73 6f 72 74 20 eys (sort
a3c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
a3d0: 20 73 65 72 76 65 72 73 29 20 73 74 72 69 6e 67 servers) string
a3e0: 3e 3d 3f 29 29 20 3b 3b 20 61 20 73 74 61 62 6c >=?)) ;; a stabl
a3f0: 65 20 6c 69 73 74 69 6e 67 0a 3b 3b 3b 20 09 20 e listing.;;; .
a400: 28 73 74 61 72 74 2d 74 69 6d 65 20 20 28 63 75 (start-time (cu
a410: 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
a420: 64 73 29 29 0a 3b 3b 3b 20 09 20 28 73 72 76 73 ds)).;;; . (srvs
a430: 74 61 74 73 20 20 20 20 28 6d 61 6b 65 2d 68 61 tats (make-ha
a440: 73 68 2d 74 61 62 6c 65 29 29 20 20 3b 3b 20 73 sh-table)) ;; s
a450: 72 76 69 64 20 3d 3e 20 73 72 76 73 74 61 74 0a rvid => srvstat.
a460: 3b 3b 3b 20 09 20 28 75 72 6c 20 20 20 20 20 20 ;;; . (url
a470: 20 20 20 28 63 6f 6e 63 20 28 61 72 65 61 2d 6d (conc (area-m
a480: 79 61 64 64 72 20 61 63 66 67 29 20 22 3a 22 20 yaddr acfg) ":"
a490: 28 61 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 (area-port acfg)
a4a0: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 28 ))).;;; ;; (
a4b0: 70 72 69 6e 74 20 22 73 63 6f 72 65 73 20 66 6f print "scores fo
a4c0: 72 20 22 20 64 62 6e 61 6d 65 20 22 3a 20 22 20 r " dbname ": "
a4d0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 (map (lambda (k)
a4e0: 28 63 6f 6e 73 20 6b 20 28 63 61 6c 63 2d 73 65 (cons k (calc-se
a4f0: 72 76 65 72 2d 73 63 6f 72 65 20 61 63 66 67 20 rver-score acfg
a500: 64 62 6e 61 6d 65 20 6b 29 29 29 20 73 6b 65 79 dbname k))) skey
a510: 73 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 s)).;;; (if
a520: 28 6e 75 6c 6c 3f 20 73 6b 65 79 73 29 0a 3b 3b (null? skeys).;;
a530: 3b 20 09 28 69 66 20 28 3e 20 28 75 70 64 61 74 ; .(if (> (updat
a540: 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 20 e-known-servers
a550: 61 63 66 67 29 20 30 29 0a 3b 3b 3b 20 09 20 20 acfg) 0).;;; .
a560: 20 20 28 67 65 74 2d 62 65 73 74 2d 73 65 72 76 (get-best-serv
a570: 65 72 20 61 63 66 67 20 64 62 6e 61 6d 65 20 6b er acfg dbname k
a580: 65 79 29 20 3b 3b 20 73 6f 6d 65 20 72 69 73 6b ey) ;; some risk
a590: 20 6f 66 20 69 6e 66 69 6e 69 74 65 20 6c 6f 6f of infinite loo
a5a0: 70 20 68 65 72 65 2c 20 54 4f 44 4f 20 61 64 64 p here, TODO add
a5b0: 20 74 72 79 20 63 6f 75 6e 74 65 72 0a 3b 3b 3b try counter.;;;
a5c0: 20 09 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b . (begin.;;;
a5d0: 20 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 . (print "
a5e0: 45 52 52 4f 52 3a 20 6e 6f 20 73 65 72 76 65 72 ERROR: no server
a5f0: 20 66 6f 75 6e 64 21 22 29 20 3b 3b 20 73 69 6e found!") ;; sin
a600: 63 65 20 74 68 69 73 20 70 72 6f 63 65 73 73 20 ce this process
a610: 69 73 20 61 6c 73 6f 20 61 20 73 65 72 76 65 72 is also a server
a620: 20 74 68 69 73 20 73 68 6f 75 6c 64 20 6e 65 76 this should nev
a630: 65 72 20 68 61 70 70 65 6e 0a 3b 3b 3b 20 09 20 er happen.;;; .
a640: 20 20 20 20 20 23 66 29 29 0a 3b 3b 3b 20 09 28 #f)).;;; .(
a650: 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 3b 3b 20 begin.;;; . ;;
a660: 28 70 72 69 6e 74 20 22 69 6e 20 67 65 74 2d 62 (print "in get-b
a670: 65 73 74 2d 73 65 72 76 65 72 20 77 69 74 68 20 est-server with
a680: 73 6b 65 79 73 3d 22 20 73 6b 65 79 73 29 0a 3b skeys=" skeys).;
a690: 3b 3b 20 09 20 20 28 69 66 20 28 3e 20 28 2d 20 ;; . (if (> (-
a6a0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
a6b0: 29 20 28 61 72 65 61 2d 6c 61 73 74 2d 73 72 76 ) (area-last-srv
a6c0: 75 70 20 61 63 66 67 29 29 20 31 30 29 0a 3b 3b up acfg)) 10).;;
a6d0: 3b 20 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ; . (begin.
a6e0: 3b 3b 3b 20 09 09 28 75 70 64 61 74 65 2d 6b 6e ;;; ..(update-kn
a6f0: 6f 77 6e 2d 73 65 72 76 65 72 73 20 61 63 66 67 own-servers acfg
a700: 29 0a 3b 3b 3b 20 09 09 28 73 64 62 67 3e 20 22 ).;;; ..(sdbg> "
a710: 67 65 74 2d 62 65 73 74 2d 73 65 72 76 65 72 22 get-best-server"
a720: 20 22 75 70 64 61 74 65 2d 6b 6e 6f 77 6e 2d 73 "update-known-s
a730: 65 72 76 65 72 73 22 20 73 74 61 72 74 2d 74 69 ervers" start-ti
a740: 6d 65 20 23 66 20 23 66 29 29 29 0a 3b 3b 3b 20 me #f #f))).;;;
a750: 0a 3b 3b 3b 20 09 20 20 3b 3b 20 66 6f 72 20 65 .;;; . ;; for e
a760: 61 63 68 20 73 65 72 76 65 72 20 6c 6f 6f 6b 20 ach server look
a770: 61 74 20 74 68 65 20 6c 69 73 74 20 6f 66 20 64 at the list of d
a780: 62 66 69 6c 65 73 2c 20 74 6f 74 61 6c 20 6e 75 bfiles, total nu
a790: 6d 62 65 72 20 6f 66 20 64 62 73 20 62 65 69 6e mber of dbs bein
a7a0: 67 20 68 61 6e 64 6c 65 64 0a 3b 3b 3b 20 09 20 g handled.;;; .
a7b0: 20 3b 3b 20 61 6e 64 20 74 68 65 20 72 61 6e 64 ;; and the rand
a7c0: 20 6e 75 6d 62 65 72 2c 20 73 61 76 65 20 74 68 number, save th
a7d0: 65 20 62 65 73 74 20 68 6f 73 74 0a 3b 3b 3b 20 e best host.;;;
a7e0: 09 20 20 3b 3b 20 61 6c 73 6f 20 64 6f 20 61 20 . ;; also do a
a7f0: 64 65 6c 69 73 74 2d 64 62 20 66 6f 72 20 65 61 delist-db for ea
a800: 63 68 20 73 65 72 76 65 72 20 64 62 66 69 6c 65 ch server dbfile
a810: 20 6e 6f 74 20 75 73 65 64 0a 3b 3b 3b 20 09 20 not used.;;; .
a820: 20 28 6c 65 74 2a 20 28 28 62 65 73 74 2d 73 65 (let* ((best-se
a830: 72 76 65 72 20 20 20 20 20 20 20 23 66 29 0a 3b rver #f).;
a840: 3b 3b 20 09 09 20 28 73 65 72 76 65 72 73 2d 74 ;; .. (servers-t
a850: 6f 2d 64 65 6c 69 73 74 20 28 6d 61 6b 65 2d 68 o-delist (make-h
a860: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 3b 3b 3b ash-table))).;;;
a870: 20 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a . (for-each.
a880: 3b 3b 3b 20 09 20 20 20 20 20 28 6c 61 6d 62 64 ;;; . (lambd
a890: 61 20 28 73 72 76 69 64 29 0a 3b 3b 3b 20 09 20 a (srvid).;;; .
a8a0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 65 (let* ((se
a8b0: 72 76 65 72 20 20 20 20 28 68 61 73 68 2d 74 61 rver (hash-ta
a8c0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
a8d0: 73 65 72 76 65 72 73 20 73 72 76 69 64 20 23 66 servers srvid #f
a8e0: 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 28 )).;;; .. (
a8f0: 73 74 61 74 73 20 20 20 20 20 28 68 61 73 68 2d stats (hash-
a900: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
a910: 74 20 28 61 72 65 61 2d 68 6f 73 74 73 74 61 74 t (area-hoststat
a920: 73 20 61 63 66 67 29 20 73 72 76 69 64 20 27 28 s acfg) srvid '(
a930: 28 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 3b 3b ())))).;;; .. ;;
a940: 20 28 70 72 69 6e 74 20 22 73 74 61 74 73 3a 20 (print "stats:
a950: 22 20 73 74 61 74 73 29 0a 3b 3b 3b 20 20 09 09 " stats).;;; ..
a960: 20 28 69 66 20 73 65 72 76 65 72 0a 3b 3b 3b 20 (if server.;;;
a970: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 .. (let* ((d
a980: 62 77 65 69 67 68 74 73 20 28 63 61 72 20 73 74 bweights (car st
a990: 61 74 73 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 ats)).;;; ...
a9a0: 20 28 73 72 76 6c 6f 61 64 20 20 20 28 6c 65 6e (srvload (len
a9b0: 67 74 68 20 28 66 69 6c 74 65 72 20 28 6c 61 6d gth (filter (lam
a9c0: 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 bda (x)(not (equ
a9d0: 61 6c 3f 20 64 62 6e 61 6d 65 20 28 63 61 72 20 al? dbname (car
a9e0: 78 29 29 29 29 20 64 62 77 65 69 67 68 74 73 29 x)))) dbweights)
a9f0: 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 28 64 )).;;; ... (d
aa00: 62 72 65 63 20 20 20 20 20 28 61 6c 69 73 74 2d brec (alist-
aa10: 72 65 66 20 64 62 6e 61 6d 65 20 64 62 77 65 69 ref dbname dbwei
aa20: 67 68 74 73 20 65 71 75 61 6c 3f 29 29 20 20 3b ghts equal?)) ;
aa30: 3b 20 67 65 74 20 74 68 65 20 70 61 69 72 20 77 ; get the pair w
aa40: 69 74 68 20 66 6e 61 6d 65 20 2e 20 72 61 6e 64 ith fname . rand
aa50: 73 63 6f 72 65 0a 3b 3b 3b 20 09 09 09 20 20 20 score.;;; ...
aa60: 20 28 72 61 6e 64 6e 75 6d 20 20 20 28 69 66 20 (randnum (if
aa70: 64 62 72 65 63 0a 3b 3b 3b 20 09 09 09 09 09 20 dbrec.;;; .....
aa80: 20 20 64 62 72 65 63 20 3b 3b 20 28 63 64 72 20 dbrec ;; (cdr
aa90: 64 62 72 65 63 29 0a 3b 3b 3b 20 09 09 09 09 09 dbrec).;;; .....
aaa0: 20 20 20 30 29 29 29 0a 3b 3b 3b 20 09 09 20 20 0))).;;; ..
aab0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
aac0: 2d 73 65 74 21 20 73 72 76 73 74 61 74 73 20 73 -set! srvstats s
aad0: 72 76 69 64 20 28 6d 61 6b 65 2d 73 72 76 73 74 rvid (make-srvst
aae0: 61 74 20 6e 75 6d 66 69 6c 65 73 3a 20 73 72 76 at numfiles: srv
aaf0: 6c 6f 61 64 20 72 61 6e 64 6e 75 6d 3a 20 72 61 load randnum: ra
ab00: 6e 64 6e 75 6d 20 70 6b 74 3a 20 73 65 72 76 65 ndnum pkt: serve
ab10: 72 29 29 29 29 29 29 0a 3b 3b 3b 20 09 20 20 20 r)))))).;;; .
ab20: 20 20 73 6b 65 79 73 29 0a 3b 3b 3b 20 09 20 20 skeys).;;; .
ab30: 20 20 0a 3b 3b 3b 20 09 20 20 20 20 28 6c 65 74 .;;; . (let
ab40: 2a 20 28 28 73 6f 72 74 65 64 20 20 20 20 28 73 * ((sorted (s
ab50: 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ort (hash-table-
ab60: 76 61 6c 75 65 73 20 73 72 76 73 74 61 74 73 29 values srvstats)
ab70: 20 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 28 6c .;;; .... (l
ab80: 61 6d 62 64 61 20 28 61 20 62 29 0a 3b 3b 3b 20 ambda (a b).;;;
ab90: 09 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
aba0: 28 6e 75 6d 66 69 6c 65 73 2d 61 20 28 73 72 76 (numfiles-a (srv
abb0: 73 74 61 74 2d 6e 75 6d 66 69 6c 65 73 20 61 29 stat-numfiles a)
abc0: 29 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 28 ).;;; ..... (
abd0: 6e 75 6d 66 69 6c 65 73 2d 62 20 28 73 72 76 73 numfiles-b (srvs
abe0: 74 61 74 2d 6e 75 6d 66 69 6c 65 73 20 62 29 29 tat-numfiles b))
abf0: 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 28 72 .;;; ..... (r
ac00: 61 6e 64 6e 75 6d 2d 61 20 20 28 73 72 76 73 74 andnum-a (srvst
ac10: 61 74 2d 72 61 6e 64 6e 75 6d 20 61 29 29 0a 3b at-randnum a)).;
ac20: 3b 3b 20 09 09 09 09 09 20 20 20 20 28 72 61 6e ;; ..... (ran
ac30: 64 6e 75 6d 2d 62 20 20 28 73 72 76 73 74 61 74 dnum-b (srvstat
ac40: 2d 72 61 6e 64 6e 75 6d 20 62 29 29 29 0a 3b 3b -randnum b))).;;
ac50: 3b 20 09 09 09 09 09 28 69 66 20 28 3c 20 6e 75 ; .....(if (< nu
ac60: 6d 66 69 6c 65 73 2d 61 20 6e 75 6d 66 69 6c 65 mfiles-a numfile
ac70: 73 2d 62 29 20 3b 3b 20 4e 6f 74 65 2c 20 49 20 s-b) ;; Note, I
ac80: 64 6f 6e 27 74 20 74 68 69 6e 6b 20 61 64 64 69 don't think addi
ac90: 6e 67 20 61 6e 20 6f 66 66 73 65 74 20 77 6f 72 ng an offset wor
aca0: 6b 73 20 68 65 72 65 2e 20 47 6f 61 6c 20 77 61 ks here. Goal wa
acb0: 73 20 6f 6e 6c 79 20 6d 6f 76 65 20 66 69 6c 65 s only move file
acc0: 20 68 61 6e 64 6c 69 6e 67 20 74 6f 20 61 20 64 handling to a d
acd0: 69 66 66 65 72 65 6e 74 20 73 65 72 76 65 72 20 ifferent server
ace0: 69 66 20 69 74 20 68 61 73 20 32 20 6c 65 73 73 if it has 2 less
acf0: 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 23 74 .;;; ..... #t
ad00: 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 28 69 .;;; ..... (i
ad10: 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 6e f (and (equal? n
ad20: 75 6d 66 69 6c 65 73 2d 61 20 6e 75 6d 66 69 6c umfiles-a numfil
ad30: 65 73 2d 62 29 0a 3b 3b 3b 20 09 09 09 09 09 09 es-b).;;; ......
ad40: 20 20 20 20 20 28 3c 20 72 61 6e 64 6e 75 6d 2d (< randnum-
ad50: 61 20 72 61 6e 64 6e 75 6d 2d 62 29 29 0a 3b 3b a randnum-b)).;;
ad60: 3b 20 09 09 09 09 09 09 23 74 0a 3b 3b 3b 20 09 ; ......#t.;;; .
ad70: 09 09 09 09 09 23 66 29 29 29 29 29 29 0a 3b 3b .....#f)))))).;;
ad80: 3b 20 09 09 20 20 20 28 62 65 73 74 20 20 20 20 ; .. (best
ad90: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 73 6f 72 (if (null? sor
ada0: 74 65 64 29 0a 3b 3b 3b 20 09 09 09 09 20 20 28 ted).;;; .... (
adb0: 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 09 09 20 20 begin.;;; ....
adc0: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
add0: 20 73 68 6f 75 6c 64 20 6e 65 76 65 72 20 62 65 should never be
ade0: 20 6e 75 6c 6c 20 64 75 65 20 74 6f 20 73 65 6c null due to sel
adf0: 66 20 61 73 20 73 65 72 76 65 72 2e 22 29 0a 3b f as server.").;
ae00: 3b 3b 20 09 09 09 09 20 20 20 20 23 66 29 0a 3b ;; .... #f).;
ae10: 3b 3b 20 09 09 09 09 20 20 28 73 72 76 73 74 61 ;; .... (srvsta
ae20: 74 2d 70 6b 74 20 28 63 61 72 20 73 6f 72 74 65 t-pkt (car sorte
ae30: 64 29 29 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 d))))).;;; .
ae40: 20 20 23 3b 28 70 72 69 6e 74 20 22 53 45 52 56 #;(print "SERV
ae50: 45 52 28 22 20 75 72 6c 20 22 29 3a 20 22 20 64 ER(" url "): " d
ae60: 62 6e 61 6d 65 20 22 3a 20 22 20 28 6d 61 70 20 bname ": " (map
ae70: 28 6c 61 6d 62 64 61 20 28 73 72 76 29 0a 3b 3b (lambda (srv).;;
ae80: 3b 20 09 09 09 09 09 09 09 20 20 20 20 28 6c 65 ; ....... (le
ae90: 74 20 28 28 70 20 28 73 72 76 73 74 61 74 2d 70 t ((p (srvstat-p
aea0: 6b 74 20 73 72 76 29 29 29 0a 3b 3b 3b 20 09 09 kt srv))).;;; ..
aeb0: 09 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e 63 ..... (conc
aec0: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 69 70 61 (alist-ref 'ipa
aed0: 64 64 72 20 70 29 20 22 3a 22 20 28 61 6c 69 73 ddr p) ":" (alis
aee0: 74 2d 72 65 66 20 27 70 6f 72 74 20 70 29 0a 3b t-ref 'port p).;
aef0: 3b 3b 20 09 09 09 09 09 09 09 09 20 20 20 20 22 ;; ........ "
af00: 28 22 20 28 73 72 76 73 74 61 74 2d 6e 75 6d 66 (" (srvstat-numf
af10: 69 6c 65 73 20 73 72 76 29 22 2c 22 28 73 72 76 iles srv)","(srv
af20: 73 74 61 74 2d 72 61 6e 64 6e 75 6d 20 73 72 76 stat-randnum srv
af30: 29 22 29 22 29 29 29 0a 3b 3b 3b 20 09 09 09 09 )")"))).;;; ....
af40: 09 09 09 20 20 20 20 73 6f 72 74 65 64 29 29 0a ... sorted)).
af50: 3b 3b 3b 20 09 20 20 20 20 20 20 62 65 73 74 29 ;;; . best)
af60: 29 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 0a 3b ))))).;;; .;
af70: 3b 3b 20 20 20 20 20 3b 3b 20 73 65 6e 64 20 6f ;; ;; send o
af80: 75 74 20 61 6e 20 22 49 27 6d 20 61 62 6f 75 74 ut an "I'm about
af90: 20 74 6f 20 65 78 69 74 20 6e 6f 74 69 63 65 20 to exit notice
afa0: 74 6f 20 61 6c 6c 20 6b 6e 6f 77 6e 20 73 65 72 to all known ser
afb0: 76 65 72 73 22 0a 3b 3b 3b 20 20 20 20 20 3b 3b vers".;;; ;;
afc0: 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 65 .;;; (define (de
afd0: 61 74 68 2d 69 6d 6d 69 6e 65 6e 74 20 61 63 66 ath-imminent acf
afe0: 67 29 0a 3b 3b 3b 20 20 20 27 28 29 29 0a 3b 3b g).;;; '()).;;
aff0: 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d ; .;;; ;;=======
b000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
b040: 3b 3b 3b 20 3b 3b 20 55 20 4c 20 45 20 58 20 20 ;;; ;; U L E X
b050: 2d 20 20 54 20 48 20 45 20 20 20 49 20 4e 20 54 - T H E I N T
b060: 20 45 20 52 20 45 20 53 20 54 20 49 20 4e 20 47 E R E S T I N G
b070: 20 20 20 53 20 54 20 55 20 46 20 46 20 21 20 21 S T U F F ! !
b080: 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;; ;;=========
b090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b0c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
b0d0: 3b 20 0a 3b 3b 3b 20 3b 3b 20 72 65 67 69 73 74 ; .;;; ;; regist
b0e0: 65 72 20 61 20 68 61 6e 64 6c 65 72 0a 3b 3b 3b er a handler.;;;
b0f0: 20 3b 3b 20 20 20 4e 4f 54 45 53 3a 0a 3b 3b 3b ;; NOTES:.;;;
b100: 20 3b 3b 20 20 20 20 20 64 62 69 6e 69 74 73 71 ;; dbinitsq
b110: 6c 20 20 20 69 73 20 72 65 73 65 72 76 65 64 20 l is reserved
b120: 66 6f 72 20 61 20 6c 69 73 74 20 6f 66 20 73 71 for a list of sq
b130: 6c 20 73 74 61 74 65 6d 65 6e 74 73 20 66 6f 72 l statements for
b140: 20 69 6e 69 74 69 61 6c 69 7a 69 6e 67 20 74 68 initializing th
b150: 65 20 64 62 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 e db.;;; ;;
b160: 64 62 69 6e 69 74 66 6e 20 20 20 20 69 73 20 72 dbinitfn is r
b170: 65 73 65 72 76 65 64 20 66 6f 72 20 61 20 64 62 eserved for a db
b180: 20 69 6e 69 74 20 66 75 6e 63 74 69 6f 6e 2c 20 init function,
b190: 69 66 20 65 78 69 73 74 73 20 63 61 6c 6c 65 64 if exists called
b1a0: 20 61 66 74 65 72 20 64 62 69 6e 69 74 73 71 6c after dbinitsql
b1b0: 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 0a 3b 3b 3b .;;; ;; .;;;
b1c0: 20 28 64 65 66 69 6e 65 20 28 72 65 67 69 73 74 (define (regist
b1d0: 65 72 20 61 63 66 67 20 6b 65 79 20 6f 62 6a 20 er acfg key obj
b1e0: 23 21 6f 70 74 69 6f 6e 61 6c 20 28 63 74 79 70 #!optional (ctyp
b1f0: 65 20 27 64 62 77 72 69 74 65 29 29 0a 3b 3b 3b e 'dbwrite)).;;;
b200: 20 20 20 28 6c 65 74 20 28 28 68 74 20 28 61 72 (let ((ht (ar
b210: 65 61 2d 72 74 61 62 6c 65 20 61 63 66 67 29 29 ea-rtable acfg))
b220: 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 28 68 ).;;; (if (h
b230: 61 73 68 2d 74 61 62 6c 65 2d 65 78 69 73 74 73 ash-table-exists
b240: 3f 20 68 74 20 6b 65 79 29 0a 3b 3b 3b 20 09 28 ? ht key).;;; .(
b250: 70 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 print "WARNING:
b260: 72 65 64 65 66 69 6e 69 74 69 6f 6e 20 6f 66 20 redefinition of
b270: 65 6e 74 72 79 20 22 20 6b 65 79 29 29 0a 3b 3b entry " key)).;;
b280: 3b 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ; (hash-tabl
b290: 65 2d 73 65 74 21 20 68 74 20 6b 65 79 20 28 6d e-set! ht key (m
b2a0: 61 6b 65 2d 63 61 6c 6c 64 61 74 20 6f 62 6a 3a ake-calldat obj:
b2b0: 20 6f 62 6a 20 63 74 79 70 65 3a 20 63 74 79 70 obj ctype: ctyp
b2c0: 65 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b e)))).;;; .;;; ;
b2d0: 3b 20 75 73 61 67 65 3a 20 72 65 67 69 73 74 65 ; usage: registe
b2e0: 72 2d 62 61 74 63 68 20 61 63 66 67 20 27 28 28 r-batch acfg '((
b2f0: 6b 65 79 31 20 2e 20 73 71 6c 31 29 20 28 6b 65 key1 . sql1) (ke
b300: 79 32 20 2e 20 73 71 6c 32 29 20 2e 2e 2e 20 29 y2 . sql2) ... )
b310: 0a 3b 3b 3b 20 3b 3b 20 4e 42 2f 2f 20 6f 62 6a .;;; ;; NB// obj
b320: 20 69 73 20 6f 66 74 65 6e 20 61 6e 20 73 71 6c is often an sql
b330: 20 71 75 65 72 79 0a 3b 3b 3b 20 3b 3b 0a 3b 3b query.;;; ;;.;;
b340: 3b 20 28 64 65 66 69 6e 65 20 28 72 65 67 69 73 ; (define (regis
b350: 74 65 72 2d 62 61 74 63 68 20 61 63 66 67 20 63 ter-batch acfg c
b360: 74 79 70 65 20 64 61 74 61 29 0a 3b 3b 3b 20 20 type data).;;;
b370: 20 28 6c 65 74 20 28 28 68 74 20 28 61 72 65 61 (let ((ht (area
b380: 2d 72 74 61 62 6c 65 20 61 63 66 67 29 29 29 0a -rtable acfg))).
b390: 3b 3b 3b 20 20 20 20 20 28 6d 61 70 20 28 6c 61 ;;; (map (la
b3a0: 6d 62 64 61 20 28 64 61 74 29 0a 3b 3b 3b 20 09 mbda (dat).;;; .
b3b0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
b3c0: 65 74 21 20 68 74 20 28 63 61 72 20 64 61 74 29 et! ht (car dat)
b3d0: 28 6d 61 6b 65 2d 63 61 6c 6c 64 61 74 20 6f 62 (make-calldat ob
b3e0: 6a 3a 20 28 63 64 72 20 64 61 74 29 20 63 74 79 j: (cdr dat) cty
b3f0: 70 65 3a 20 63 74 79 70 65 29 29 29 0a 3b 3b 3b pe: ctype))).;;;
b400: 20 09 20 64 61 74 61 29 29 29 0a 3b 3b 3b 20 0a . data))).;;; .
b410: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 69 6e 69 ;;; (define (ini
b420: 74 69 61 6c 69 7a 65 2d 61 72 65 61 2d 63 61 6c tialize-area-cal
b430: 6c 73 2d 66 72 6f 6d 2d 73 70 65 63 66 69 6c 65 ls-from-specfile
b440: 20 61 72 65 61 20 73 70 65 63 66 69 6c 65 29 0a area specfile).
b450: 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 63 61 ;;; (let* ((ca
b460: 6c 6c 73 70 65 63 20 28 77 69 74 68 2d 69 6e 70 llspec (with-inp
b470: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 73 70 65 ut-from-file spe
b480: 63 66 69 6c 65 20 72 65 61 64 20 29 29 29 0a 3b cfile read ))).;
b490: 3b 3b 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ;; (for-each
b4a0: 20 28 6c 61 6d 62 64 61 20 28 67 72 6f 75 70 29 (lambda (group)
b4b0: 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 .;;;
b4c0: 20 20 20 20 20 28 72 65 67 69 73 74 65 72 2d 62 (register-b
b4d0: 61 74 63 68 0a 3b 3b 3b 20 20 20 20 20 20 20 20 atch.;;;
b4e0: 20 20 20 20 20 20 20 20 20 20 61 72 65 61 0a 3b area.;
b4f0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
b500: 20 20 20 20 28 63 61 72 20 67 72 6f 75 70 29 0a (car group).
b510: 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;;
b520: 20 20 20 20 20 28 63 64 72 20 67 72 6f 75 70 29 (cdr group)
b530: 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 )).;;;
b540: 20 20 20 20 20 63 61 6c 6c 73 70 65 63 29 29 29 callspec)))
b550: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 67 65 74 .;;; .;;; ;; get
b560: 2d 72 65 6e 74 72 79 0a 3b 3b 3b 20 3b 3b 0a 3b -rentry.;;; ;;.;
b570: 3b 3b 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d ;; (define (get-
b580: 72 65 6e 74 72 79 20 61 63 66 67 20 6b 65 79 29 rentry acfg key)
b590: 0a 3b 3b 3b 20 20 20 28 68 61 73 68 2d 74 61 62 .;;; (hash-tab
b5a0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
b5b0: 61 72 65 61 2d 72 74 61 62 6c 65 20 61 63 66 67 area-rtable acfg
b5c0: 29 20 6b 65 79 20 23 66 29 29 0a 3b 3b 3b 20 0a ) key #f)).;;; .
b5d0: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 67 65 74 ;;; (define (get
b5e0: 2d 72 73 71 6c 20 61 63 66 67 20 6b 65 79 29 0a -rsql acfg key).
b5f0: 3b 3b 3b 20 20 20 28 6c 65 74 20 28 28 63 64 61 ;;; (let ((cda
b600: 74 20 28 67 65 74 2d 72 65 6e 74 72 79 20 61 63 t (get-rentry ac
b610: 66 67 20 6b 65 79 29 29 29 0a 3b 3b 3b 20 20 20 fg key))).;;;
b620: 20 20 28 69 66 20 63 64 61 74 0a 3b 3b 3b 20 09 (if cdat.;;; .
b630: 28 63 61 6c 6c 64 61 74 2d 6f 62 6a 20 63 64 61 (calldat-obj cda
b640: 74 29 0a 3b 3b 3b 20 09 23 66 29 29 29 0a 3b 3b t).;;; .#f))).;;
b650: 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b ; .;;; .;;; .;;;
b660: 20 3b 3b 20 62 6c 6f 63 6b 69 6e 67 20 63 61 6c ;; blocking cal
b670: 6c 3a 0a 3b 3b 3b 20 3b 3b 20 20 20 20 63 6c 69 l:.;;; ;; cli
b680: 65 6e 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ent
b690: 20 20 20 20 20 20 20 20 20 20 20 20 73 65 72 76 serv
b6a0: 65 72 0a 3b 3b 3b 20 3b 3b 20 20 20 20 2d 2d 2d er.;;; ;; ---
b6b0: 2d 2d 2d 20 20 20 20 20 20 20 20 20 20 20 20 20 ---
b6c0: 20 20 20 20 20 20 20 20 20 20 20 20 2d 2d 2d 2d ----
b6d0: 2d 2d 0a 3b 3b 3b 20 3b 3b 20 20 20 20 63 61 6c --.;;; ;; cal
b6e0: 6c 28 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 73 65 l().;;; ;; se
b6f0: 6e 64 2d 6d 65 73 73 61 67 65 28 29 0a 3b 3b 3b nd-message().;;;
b700: 20 3b 3b 20 20 20 20 6e 6d 73 67 2d 73 65 6e 64 ;; nmsg-send
b710: 28 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 20 20 ().;;; ;;
b720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b730: 20 20 20 20 20 20 20 20 20 20 20 20 6e 6d 73 67 nmsg
b740: 2d 72 65 63 65 69 76 65 28 29 0a 3b 3b 3b 20 3b -receive().;;; ;
b750: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
b760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b770: 20 20 20 20 6e 6d 73 67 2d 72 65 73 70 6f 6e 64 nmsg-respond
b780: 28 61 63 6b 2c 63 6f 6f 6b 69 65 29 0a 3b 3b 3b (ack,cookie).;;;
b790: 20 3b 3b 20 20 20 20 61 63 6b 2c 20 63 6f 6f 6b ;; ack, cook
b7a0: 69 65 0a 3b 3b 3b 20 3b 3b 20 20 20 20 6d 62 6f ie.;;; ;; mbo
b7b0: 78 2d 74 68 72 65 61 64 2d 77 61 69 74 28 63 6f x-thread-wait(co
b7c0: 6f 6b 69 65 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 okie).;;; ;;
b7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e n
b7f0: 6d 73 67 2d 73 65 6e 64 28 63 6c 69 65 6e 74 2c msg-send(client,
b800: 63 6f 6f 6b 69 65 2c 72 65 73 75 6c 74 29 0a 3b cookie,result).;
b810: 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 6e 6d 73 ;; ;; nms
b820: 67 2d 72 65 73 70 6f 6e 64 28 61 63 6b 29 0a 3b g-respond(ack).;
b830: 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 72 65 74 ;; ;; ret
b840: 75 72 6e 20 72 65 73 75 6c 74 0a 3b 3b 3b 20 3b urn result.;;; ;
b850: 3b 0a 3b 3b 3b 20 3b 3b 20 72 65 73 65 72 76 65 ;.;;; ;; reserve
b860: 64 20 61 63 74 69 6f 6e 3a 0a 3b 3b 3b 20 3b 3b d action:.;;; ;;
b870: 20 20 20 20 27 69 6d 6d 65 64 69 61 74 65 0a 3b 'immediate.;
b880: 3b 3b 20 3b 3b 20 20 20 20 27 64 62 69 6e 69 74 ;; ;; 'dbinit
b890: 73 71 6c 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 sql.;;; ;;.;;; (
b8a0: 64 65 66 69 6e 65 20 28 63 61 6c 6c 20 61 63 66 define (call acf
b8b0: 67 20 64 62 6e 61 6d 65 20 61 63 74 69 6f 6e 20 g dbname action
b8c0: 70 61 72 61 6d 73 20 23 21 6f 70 74 69 6f 6e 61 params #!optiona
b8d0: 6c 20 28 63 6f 75 6e 74 20 30 29 29 0a 3b 3b 3b l (count 0)).;;;
b8e0: 20 20 20 28 6c 65 74 2a 20 28 28 63 61 6c 6c 2d (let* ((call-
b8f0: 73 74 61 72 74 2d 74 69 6d 65 20 20 20 20 20 28 start-time (
b900: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
b910: 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 28 73 72 onds)).;;; . (sr
b920: 76 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 v
b930: 20 20 28 67 65 74 2d 62 65 73 74 2d 73 65 72 76 (get-best-serv
b940: 65 72 20 61 63 66 67 20 64 62 6e 61 6d 65 20 61 er acfg dbname a
b950: 63 74 69 6f 6e 29 29 0a 3b 3b 3b 20 09 20 28 70 ction)).;;; . (p
b960: 6f 73 74 2d 67 65 74 2d 73 74 61 72 74 2d 74 69 ost-get-start-ti
b970: 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c me (current-mill
b980: 69 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 iseconds)).;;; .
b990: 20 28 72 64 61 74 20 20 20 20 20 20 20 20 20 20 (rdat
b9a0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
b9b0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 61 e-ref/default (a
b9c0: 72 65 61 2d 72 74 61 62 6c 65 20 61 63 66 67 29 rea-rtable acfg)
b9d0: 20 61 63 74 69 6f 6e 20 23 66 29 29 0a 3b 3b 3b action #f)).;;;
b9e0: 20 09 20 28 6d 79 69 64 20 20 20 20 20 20 20 20 . (myid
b9f0: 20 20 20 20 20 20 20 20 28 74 72 69 6d 2d 70 6b (trim-pk
ba00: 74 69 64 20 28 61 72 65 61 2d 70 6b 74 69 64 20 tid (area-pktid
ba10: 61 63 66 67 29 29 29 0a 3b 3b 3b 20 09 20 28 73 acfg))).;;; . (s
ba20: 72 76 69 64 20 20 20 20 20 20 20 20 20 20 20 20 rvid
ba30: 20 20 20 28 74 72 69 6d 2d 70 6b 74 69 64 20 28 (trim-pktid (
ba40: 61 6c 69 73 74 2d 72 65 66 20 27 5a 20 73 72 76 alist-ref 'Z srv
ba50: 29 29 29 0a 3b 3b 3b 20 09 20 28 63 6f 6f 6b 69 ))).;;; . (cooki
ba60: 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 e (
ba70: 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 6d 79 69 64 make-cookie myid
ba80: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 73 64 62 ))).;;; (sdb
ba90: 67 3e 20 22 63 61 6c 6c 22 20 22 67 65 74 2d 62 g> "call" "get-b
baa0: 65 73 74 2d 73 65 72 76 65 72 22 20 63 61 6c 6c est-server" call
bab0: 2d 73 74 61 72 74 2d 74 69 6d 65 20 23 66 20 63 -start-time #f c
bac0: 61 6c 6c 2d 73 74 61 72 74 2d 74 69 6d 65 20 22 all-start-time "
bad0: 20 66 72 6f 6d 3a 20 22 20 6d 79 69 64 20 22 20 from: " myid "
bae0: 74 6f 20 73 65 72 76 65 72 3a 20 22 20 73 72 76 to server: " srv
baf0: 69 64 20 22 20 66 6f 72 20 22 20 64 62 6e 61 6d id " for " dbnam
bb00: 65 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 e " action: " ac
bb10: 74 69 6f 6e 20 22 20 70 61 72 61 6d 73 3a 20 22 tion " params: "
bb20: 20 70 61 72 61 6d 73 20 22 20 72 64 61 74 3a 20 params " rdat:
bb30: 22 20 72 64 61 74 29 0a 3b 3b 3b 20 20 20 20 20 " rdat).;;;
bb40: 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a 20 63 61 (print "INFO: ca
bb50: 6c 6c 20 74 6f 20 22 20 28 61 6c 69 73 74 2d 72 ll to " (alist-r
bb60: 65 66 20 27 69 70 61 64 64 72 20 73 72 76 29 20 ef 'ipaddr srv)
bb70: 22 3a 22 20 28 61 6c 69 73 74 2d 72 65 66 20 27 ":" (alist-ref '
bb80: 70 6f 72 74 20 73 72 76 29 20 22 20 66 72 6f 6d port srv) " from
bb90: 20 22 20 28 61 72 65 61 2d 6d 79 61 64 64 72 20 " (area-myaddr
bba0: 61 63 66 67 29 20 22 3a 22 20 28 61 72 65 61 2d acfg) ":" (area-
bbb0: 70 6f 72 74 20 61 63 66 67 29 20 22 20 66 6f 72 port acfg) " for
bbc0: 20 22 20 64 62 6e 61 6d 65 29 0a 3b 3b 3b 20 20 " dbname).;;;
bbd0: 20 20 20 28 69 66 20 28 61 6e 64 20 73 72 76 20 (if (and srv
bbe0: 72 64 61 74 29 20 3b 3b 20 6e 65 65 64 20 62 6f rdat) ;; need bo
bbf0: 74 68 20 74 6f 20 64 69 73 70 61 74 63 68 20 61 th to dispatch a
bc00: 20 72 65 71 75 65 73 74 0a 3b 3b 3b 20 09 28 6c request.;;; .(l
bc10: 65 74 2a 20 28 28 72 69 70 61 64 64 72 20 20 28 et* ((ripaddr (
bc20: 61 6c 69 73 74 2d 72 65 66 20 27 69 70 61 64 64 alist-ref 'ipadd
bc30: 72 20 73 72 76 29 29 0a 3b 3b 3b 20 09 20 20 20 r srv)).;;; .
bc40: 20 20 20 20 28 72 73 72 76 69 64 20 20 20 28 61 (rsrvid (a
bc50: 6c 69 73 74 2d 72 65 66 20 27 5a 20 73 72 76 29 list-ref 'Z srv)
bc60: 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 72 ).;;; . (r
bc70: 70 6f 72 74 20 20 20 20 28 61 6e 79 2d 3e 6e 75 port (any->nu
bc80: 6d 62 65 72 20 28 61 6c 69 73 74 2d 72 65 66 20 mber (alist-ref
bc90: 27 70 6f 72 74 20 20 20 73 72 76 29 29 29 0a 3b 'port srv))).;
bca0: 3b 3b 20 09 20 20 20 20 20 20 20 28 72 65 73 2d ;; . (res-
bcb0: 66 75 6c 6c 20 28 69 66 20 28 61 6e 64 20 28 65 full (if (and (e
bcc0: 71 75 61 6c 3f 20 72 69 70 61 64 64 72 20 28 61 qual? ripaddr (a
bcd0: 72 65 61 2d 6d 79 61 64 64 72 20 61 63 66 67 29 rea-myaddr acfg)
bce0: 29 0a 3b 3b 3b 20 09 09 09 09 20 20 28 65 71 75 ).;;; .... (equ
bcf0: 61 6c 3f 20 72 70 6f 72 74 20 20 20 28 61 72 65 al? rport (are
bd00: 61 2d 70 6f 72 74 20 61 63 66 67 29 29 29 0a 3b a-port acfg))).;
bd10: 3b 3b 20 09 09 09 20 20 20 20 20 28 72 65 71 75 ;; ... (requ
bd20: 65 73 74 20 61 63 66 67 20 72 69 70 61 64 64 72 est acfg ripaddr
bd30: 20 72 70 6f 72 74 20 28 61 72 65 61 2d 70 6b 74 rport (area-pkt
bd40: 69 64 20 61 63 66 67 29 20 61 63 74 69 6f 6e 20 id acfg) action
bd50: 63 6f 6f 6b 69 65 20 64 62 6e 61 6d 65 20 70 61 cookie dbname pa
bd60: 72 61 6d 73 29 0a 3b 3b 3b 20 09 09 09 20 20 20 rams).;;; ...
bd70: 20 20 28 73 61 66 65 2d 63 61 6c 6c 20 27 72 65 (safe-call 're
bd80: 71 75 65 73 74 20 72 69 70 61 64 64 72 20 72 70 quest ripaddr rp
bd90: 6f 72 74 0a 3b 3b 3b 20 09 09 09 09 09 28 61 72 ort.;;; .....(ar
bda0: 65 61 2d 6d 79 61 64 64 72 20 61 63 66 67 29 0a ea-myaddr acfg).
bdb0: 3b 3b 3b 20 09 09 09 09 09 28 61 72 65 61 2d 70 ;;; .....(area-p
bdc0: 6f 72 74 20 20 20 61 63 66 67 29 0a 3b 3b 3b 20 ort acfg).;;;
bdd0: 09 09 09 09 09 23 3b 28 61 72 65 61 2d 70 6b 74 .....#;(area-pkt
bde0: 69 64 20 61 63 66 67 29 0a 3b 3b 3b 20 09 09 09 id acfg).;;; ...
bdf0: 09 09 72 73 72 76 69 64 0a 3b 3b 3b 20 09 09 09 ..rsrvid.;;; ...
be00: 09 09 61 63 74 69 6f 6e 20 63 6f 6f 6b 69 65 20 ..action cookie
be10: 64 62 6e 61 6d 65 20 70 61 72 61 6d 73 29 29 29 dbname params)))
be20: 29 0a 3b 3b 3b 20 09 20 20 3b 3b 20 28 70 72 69 ).;;; . ;; (pri
be30: 6e 74 20 22 72 65 73 2d 66 75 6c 6c 3a 20 22 20 nt "res-full: "
be40: 72 65 73 2d 66 75 6c 6c 29 0a 3b 3b 3b 20 09 20 res-full).;;; .
be50: 20 28 6d 61 74 63 68 20 72 65 73 2d 66 75 6c 6c (match res-full
be60: 0a 3b 3b 3b 20 09 20 20 20 20 28 28 72 65 73 70 .;;; . ((resp
be70: 6f 6e 73 65 2d 6f 6b 20 72 65 73 70 6f 6e 73 65 onse-ok response
be80: 2d 6d 73 67 20 72 65 6d 20 2e 2e 2e 29 0a 3b 3b -msg rem ...).;;
be90: 3b 20 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ; . (let* ((
bea0: 73 65 6e 64 2d 6d 65 73 73 61 67 65 2d 74 69 6d send-message-tim
beb0: 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 e (current-milli
bec0: 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 09 seconds)).;;; ..
bed0: 20 20 20 20 3b 3b 20 28 6d 61 74 63 68 20 72 65 ;; (match re
bee0: 73 2d 66 75 6c 6c 0a 3b 3b 3b 20 09 09 20 20 20 s-full.;;; ..
bef0: 20 3b 3b 20 20 28 28 72 65 73 70 6f 6e 73 65 2d ;; ((response-
bf00: 6f 6b 20 72 65 73 70 6f 6e 73 65 2d 6d 73 67 29 ok response-msg)
bf10: 0a 3b 3b 3b 20 09 09 20 20 20 20 3b 3b 20 28 72 .;;; .. ;; (r
bf20: 65 73 70 6f 6e 73 65 2d 6f 6b 20 20 28 63 61 72 esponse-ok (car
bf30: 20 72 65 73 2d 66 75 6c 6c 29 29 0a 3b 3b 3b 20 res-full)).;;;
bf40: 09 09 20 20 20 20 3b 3b 20 28 72 65 73 70 6f 6e .. ;; (respon
bf50: 73 65 2d 6d 73 67 20 28 63 61 64 72 20 72 65 73 se-msg (cadr res
bf60: 2d 66 75 6c 6c 29 0a 3b 3b 3b 20 09 09 20 20 20 -full).;;; ..
bf70: 20 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 3b ).;;; . ;
bf80: 3b 20 28 72 65 73 20 28 74 61 6b 65 20 72 65 73 ; (res (take res
bf90: 2d 66 75 6c 6c 20 33 29 29 29 20 3b 3b 20 63 74 -full 3))) ;; ct
bfa0: 79 70 65 20 3d 3d 20 61 63 74 69 6f 6e 2c 20 54 ype == action, T
bfb0: 4f 44 4f 3a 20 63 6f 6e 76 65 72 67 65 20 6f 6e ODO: converge on
bfc0: 20 6f 6e 65 20 74 65 72 6d 20 3c 3c 3d 3d 3d 20 one term <<===
bfd0: 77 68 61 74 20 77 61 73 20 74 68 69 73 3f 20 42 what was this? B
bfe0: 55 47 20 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 UG .;;; .
bff0: 3b 3b 20 28 70 72 69 6e 74 20 22 75 6c 65 78 3a ;; (print "ulex:
c000: 63 61 6c 6c 3a 20 73 65 6e 64 2d 6d 65 73 73 61 call: send-messa
c010: 67 65 20 74 6f 6f 6b 20 22 20 28 2d 20 73 65 6e ge took " (- sen
c020: 64 2d 6d 65 73 73 61 67 65 2d 74 69 6d 65 20 70 d-message-time p
c030: 6f 73 74 2d 67 65 74 2d 73 74 61 72 74 2d 74 69 ost-get-start-ti
c040: 6d 65 29 20 22 20 6d 73 20 70 61 72 61 6d 73 3d me) " ms params=
c050: 22 20 70 61 72 61 6d 73 29 0a 3b 3b 3b 20 09 20 " params).;;; .
c060: 20 20 20 20 20 20 28 73 64 62 67 3e 20 22 63 61 (sdbg> "ca
c070: 6c 6c 22 20 22 73 65 6e 64 2d 6d 65 73 73 61 67 ll" "send-messag
c080: 65 22 20 70 6f 73 74 2d 67 65 74 2d 73 74 61 72 e" post-get-star
c090: 74 2d 74 69 6d 65 20 23 66 20 63 61 6c 6c 2d 73 t-time #f call-s
c0a0: 74 61 72 74 2d 74 69 6d 65 29 0a 3b 3b 3b 20 09 tart-time).;;; .
c0b0: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b 3b (cond.;;;
c0c0: 20 09 09 28 28 6e 6f 74 20 72 65 73 70 6f 6e 73 ..((not respons
c0d0: 65 2d 6f 6b 29 20 23 66 29 0a 3b 3b 3b 20 09 09 e-ok) #f).;;; ..
c0e0: 28 28 6d 65 6d 62 65 72 20 72 65 73 70 6f 6e 73 ((member respons
c0f0: 65 2d 6d 73 67 20 27 28 22 64 62 20 72 65 61 64 e-msg '("db read
c100: 20 73 75 62 6d 69 74 74 65 64 22 20 22 64 62 20 submitted" "db
c110: 77 72 69 74 65 20 73 75 62 6d 69 74 74 65 64 22 write submitted"
c120: 29 29 0a 3b 3b 3b 20 09 09 20 28 6c 65 74 2a 20 )).;;; .. (let*
c130: 28 28 63 6f 6f 6b 69 65 2d 69 64 20 20 20 28 63 ((cookie-id (c
c140: 61 64 64 64 72 20 72 65 73 2d 66 75 6c 6c 29 29 adddr res-full))
c150: 0a 3b 3b 3b 20 09 09 09 28 6d 62 6f 78 20 20 20 .;;; ...(mbox
c160: 20 20 20 20 20 28 6d 61 6b 65 2d 6d 61 69 6c 62 (make-mailb
c170: 6f 78 29 29 0a 3b 3b 3b 20 09 09 09 28 6d 62 6f ox)).;;; ...(mbo
c180: 78 2d 74 69 6d 65 20 20 20 28 63 75 72 72 65 6e x-time (curren
c190: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 t-milliseconds))
c1a0: 29 0a 3b 3b 3b 20 09 09 20 20 20 28 68 61 73 68 ).;;; .. (hash
c1b0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 61 72 65 -table-set! (are
c1c0: 61 2d 63 6f 6f 6b 69 65 32 6d 62 6f 78 20 61 63 a-cookie2mbox ac
c1d0: 66 67 29 20 63 6f 6f 6b 69 65 2d 69 64 20 6d 62 fg) cookie-id mb
c1e0: 6f 78 29 0a 3b 3b 3b 20 09 09 20 20 20 28 6c 65 ox).;;; .. (le
c1f0: 74 2a 20 28 28 6d 62 6f 78 2d 74 69 6d 65 6f 75 t* ((mbox-timeou
c200: 74 2d 73 65 63 73 20 20 20 20 32 30 29 0a 3b 3b t-secs 20).;;
c210: 3b 20 09 09 09 20 20 28 6d 62 6f 78 2d 74 69 6d ; ... (mbox-tim
c220: 65 6f 75 74 2d 72 65 73 75 6c 74 20 27 4d 42 4f eout-result 'MBO
c230: 58 5f 54 49 4d 45 4f 55 54 29 0a 3b 3b 3b 20 09 X_TIMEOUT).;;; .
c240: 09 09 20 20 28 72 65 73 20 20 20 20 20 20 20 20 .. (res
c250: 20 20 20 20 20 20 20 20 20 20 28 6d 61 69 6c 62 (mailb
c260: 6f 78 2d 72 65 63 65 69 76 65 21 20 6d 62 6f 78 ox-receive! mbox
c270: 20 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d 73 65 mbox-timeout-se
c280: 63 73 20 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d cs mbox-timeout-
c290: 72 65 73 75 6c 74 29 29 0a 3b 3b 3b 20 09 09 09 result)).;;; ...
c2a0: 20 20 28 6d 62 6f 78 2d 72 65 63 65 69 76 65 2d (mbox-receive-
c2b0: 74 69 6d 65 20 20 20 20 28 63 75 72 72 65 6e 74 time (current
c2c0: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 -milliseconds)))
c2d0: 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 68 61 73 .;;; .. (has
c2e0: 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
c2f0: 28 61 72 65 61 2d 63 6f 6f 6b 69 65 32 6d 62 6f (area-cookie2mbo
c300: 78 20 61 63 66 67 29 20 63 6f 6f 6b 69 65 2d 69 x acfg) cookie-i
c310: 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 73 d).;;; .. (s
c320: 64 62 67 3e 20 22 63 61 6c 6c 22 20 22 6d 61 69 dbg> "call" "mai
c330: 6c 62 6f 78 2d 72 65 63 65 69 76 65 22 20 6d 62 lbox-receive" mb
c340: 6f 78 2d 74 69 6d 65 20 23 66 20 63 61 6c 6c 2d ox-time #f call-
c350: 73 74 61 72 74 2d 74 69 6d 65 20 22 20 66 72 6f start-time " fro
c360: 6d 3a 20 22 20 6d 79 69 64 20 22 20 74 6f 20 73 m: " myid " to s
c370: 65 72 76 65 72 3a 20 22 20 73 72 76 69 64 20 22 erver: " srvid "
c380: 20 66 6f 72 20 22 20 64 62 6e 61 6d 65 29 0a 3b for " dbname).;
c390: 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 28 70 72 ;; .. ;; (pr
c3a0: 69 6e 74 20 22 75 6c 65 78 3a 63 61 6c 6c 20 6d int "ulex:call m
c3b0: 61 69 6c 62 6f 78 2d 72 65 63 65 69 76 65 20 74 ailbox-receive t
c3c0: 6f 6f 6b 20 22 20 28 2d 20 6d 62 6f 78 2d 72 65 ook " (- mbox-re
c3d0: 63 65 69 76 65 2d 74 69 6d 65 20 6d 62 6f 78 2d ceive-time mbox-
c3e0: 74 69 6d 65 29 20 22 6d 73 20 70 61 72 61 6d 73 time) "ms params
c3f0: 3d 22 20 70 61 72 61 6d 73 29 0a 3b 3b 3b 20 09 =" params).;;; .
c400: 09 20 20 20 20 20 72 65 73 29 29 29 0a 3b 3b 3b . res))).;;;
c410: 20 09 09 28 65 6c 73 65 0a 3b 3b 3b 20 09 09 20 ..(else.;;; ..
c420: 28 70 72 69 6e 74 20 22 55 6e 68 61 6e 64 6c 65 (print "Unhandle
c430: 64 20 72 65 73 70 6f 6e 73 65 20 5c 22 22 72 65 d response \""re
c440: 73 70 6f 6e 73 65 2d 6d 73 67 22 5c 22 22 29 0a sponse-msg"\"").
c450: 3b 3b 3b 20 09 09 20 23 66 29 29 0a 3b 3b 3b 20 ;;; .. #f)).;;;
c460: 09 20 20 20 20 20 20 20 3b 3b 20 64 65 70 65 6e . ;; depen
c470: 64 69 6e 67 20 6f 6e 20 77 68 61 74 20 61 63 74 ding on what act
c480: 69 6f 6e 20 28 69 2e 65 2e 20 63 74 79 70 65 29 ion (i.e. ctype)
c490: 20 69 73 20 77 65 20 77 69 6c 6c 20 62 6c 6f 63 is we will bloc
c4a0: 6b 20 68 65 72 65 20 77 61 69 74 69 6e 67 20 66 k here waiting f
c4b0: 6f 72 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 3b or.;;; . ;
c4c0: 3b 20 61 6c 6c 20 74 68 65 20 64 61 74 61 20 28 ; all the data (
c4d0: 6d 65 63 68 61 6e 69 73 6d 20 74 6f 20 62 65 20 mechanism to be
c4e0: 64 65 74 65 72 6d 69 6e 65 64 29 0a 3b 3b 3b 20 determined).;;;
c4f0: 09 20 20 20 20 20 20 20 3b 3b 0a 3b 3b 3b 20 09 . ;;.;;; .
c500: 20 20 20 20 20 20 20 3b 3b 20 69 66 20 72 65 73 ;; if res
c510: 20 69 73 20 61 20 22 77 6f 72 6b 69 6e 67 20 6f is a "working o
c520: 6e 20 69 74 22 20 74 68 65 6e 20 77 61 69 74 0a n it" then wait.
c530: 3b 3b 3b 20 09 20 20 20 20 20 20 20 3b 3b 20 20 ;;; . ;;
c540: 20 20 77 61 69 74 20 66 6f 72 20 72 65 73 75 6c wait for resul
c550: 74 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 3b 3b t.;;; . ;;
c560: 20 6d 61 69 6c 62 6f 78 20 74 68 72 65 61 64 20 mailbox thread
c570: 77 61 69 74 20 6f 6e 20 0a 3b 3b 3b 20 09 20 20 wait on .;;; .
c580: 20 20 20 20 20 0a 3b 3b 3b 20 09 20 20 20 20 20 .;;; .
c590: 20 20 3b 3b 20 69 66 20 72 65 73 20 69 73 20 61 ;; if res is a
c5a0: 20 22 63 61 6e 27 74 20 68 65 6c 70 20 79 6f 75 "can't help you
c5b0: 22 20 74 68 65 6e 20 74 72 79 20 61 20 64 69 66 " then try a dif
c5c0: 66 65 72 65 6e 74 20 73 65 72 76 65 72 0a 3b 3b ferent server.;;
c5d0: 3b 20 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ; . ;; if
c5e0: 72 65 73 20 69 73 20 61 20 22 61 63 6b 22 20 28 res is a "ack" (
c5f0: 65 2e 67 2e 20 66 6f 72 20 6f 6e 65 2d 73 68 6f e.g. for one-sho
c600: 74 20 72 65 71 75 65 73 74 73 29 20 74 68 65 6e t requests) then
c610: 20 72 65 74 75 72 6e 20 72 65 73 0a 3b 3b 3b 20 return res.;;;
c620: 09 20 20 20 20 20 20 20 29 29 0a 3b 3b 3b 20 09 . )).;;; .
c630: 20 20 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 20 (else.;;; .
c640: 20 20 20 20 28 69 66 20 28 3c 20 63 6f 75 6e 74 (if (< count
c650: 20 31 30 29 0a 3b 3b 3b 20 09 09 20 28 6c 65 74 10).;;; .. (let
c660: 2a 20 28 28 75 72 6c 20 28 63 6f 6e 63 20 28 61 * ((url (conc (a
c670: 6c 69 73 74 2d 72 65 66 20 27 69 70 61 64 64 72 list-ref 'ipaddr
c680: 20 73 72 76 29 20 22 3a 22 20 28 61 6c 69 73 74 srv) ":" (alist
c690: 2d 72 65 66 20 27 70 6f 72 74 20 73 72 76 29 29 -ref 'port srv))
c6a0: 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 74 68 72 )).;;; .. (thr
c6b0: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 3b 3b ead-sleep! 1).;;
c6c0: 3b 20 09 09 20 20 20 28 70 72 69 6e 74 20 22 45 ; .. (print "E
c6d0: 52 52 4f 52 3a 20 42 61 64 20 72 65 73 75 6c 74 RROR: Bad result
c6e0: 20 66 72 6f 6d 20 22 20 75 72 6c 20 22 2c 20 64 from " url ", d
c6f0: 62 6e 61 6d 65 3a 20 22 20 64 62 6e 61 6d 65 20 bname: " dbname
c700: 22 2c 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 ", action: " act
c710: 69 6f 6e 20 22 2c 20 70 61 72 61 6d 73 3a 20 22 ion ", params: "
c720: 20 70 61 72 61 6d 73 20 22 2e 20 54 72 79 69 6e params ". Tryin
c730: 67 20 61 67 61 69 6e 20 69 6e 20 31 20 73 65 63 g again in 1 sec
c740: 6f 6e 64 2e 22 29 0a 3b 3b 3b 20 09 09 20 20 20 ond.").;;; ..
c750: 28 63 61 6c 6c 20 61 63 66 67 20 64 62 6e 61 6d (call acfg dbnam
c760: 65 20 61 63 74 69 6f 6e 20 70 61 72 61 6d 73 20 e action params
c770: 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 0a 3b 3b (+ count 1))).;;
c780: 3b 20 09 09 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 ; .. (begin.;;;
c790: 09 09 20 20 20 28 65 72 72 6f 72 20 28 63 6f 6e .. (error (con
c7a0: 63 20 22 45 52 52 4f 52 3a 20 22 20 63 6f 75 6e c "ERROR: " coun
c7b0: 74 20 22 20 74 72 69 65 73 2c 20 73 74 69 6c 6c t " tries, still
c7c0: 20 68 61 76 65 20 69 6d 70 72 6f 70 65 72 20 72 have improper r
c7d0: 65 73 70 6f 6e 73 65 20 72 65 73 2d 66 75 6c 6c esponse res-full
c7e0: 3d 22 20 72 65 73 2d 66 75 6c 6c 29 29 29 29 29 =" res-full)))))
c7f0: 29 29 0a 3b 3b 3b 20 09 28 62 65 67 69 6e 0a 3b )).;;; .(begin.;
c800: 3b 3b 20 09 20 20 28 69 66 20 28 6e 6f 74 20 72 ;; . (if (not r
c810: 64 61 74 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 dat).;;; .
c820: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 61 (print "ERROR: a
c830: 63 74 69 6f 6e 20 22 20 61 63 74 69 6f 6e 20 22 ction " action "
c840: 20 6e 6f 74 20 72 65 67 69 73 74 65 72 65 64 2e not registered.
c850: 22 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 69 ").;;; . (i
c860: 66 20 28 3c 20 63 6f 75 6e 74 20 31 30 29 0a 3b f (< count 10).;
c870: 3b 3b 20 09 09 20 28 62 65 67 69 6e 0a 3b 3b 3b ;; .. (begin.;;;
c880: 20 09 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c .. (thread-sl
c890: 65 65 70 21 20 31 29 0a 3b 3b 3b 20 09 09 20 20 eep! 1).;;; ..
c8a0: 20 28 61 72 65 61 2d 68 6f 73 74 73 2d 73 65 74 (area-hosts-set
c8b0: 21 20 61 63 66 67 20 28 6d 61 6b 65 2d 68 61 73 ! acfg (make-has
c8c0: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 6c 65 h-table)) ;; cle
c8d0: 61 72 20 6f 75 74 20 61 6c 6c 20 6b 6e 6f 77 6e ar out all known
c8e0: 20 68 6f 73 74 73 0a 3b 3b 3b 20 09 09 20 20 20 hosts.;;; ..
c8f0: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 6e (print "ERROR: n
c900: 6f 20 73 65 72 76 65 72 20 66 6f 75 6e 64 2c 20 o server found,
c910: 73 72 76 3d 22 20 73 72 76 20 22 2c 20 74 72 79 srv=" srv ", try
c920: 69 6e 67 20 61 67 61 69 6e 20 69 6e 20 31 20 73 ing again in 1 s
c930: 65 63 6f 6e 64 73 22 29 0a 3b 3b 3b 20 09 09 20 econds").;;; ..
c940: 20 20 28 63 61 6c 6c 20 61 63 66 67 20 64 62 6e (call acfg dbn
c950: 61 6d 65 20 61 63 74 69 6f 6e 20 70 61 72 61 6d ame action param
c960: 73 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 0a s (+ count 1))).
c970: 3b 3b 3b 20 09 09 20 28 62 65 67 69 6e 0a 3b 3b ;;; .. (begin.;;
c980: 3b 20 09 09 20 20 20 28 65 72 72 6f 72 20 28 63 ; .. (error (c
c990: 6f 6e 63 20 22 45 52 52 4f 52 3a 20 6e 6f 20 73 onc "ERROR: no s
c9a0: 65 72 76 65 72 20 66 6f 75 6e 64 20 61 66 74 65 erver found afte
c9b0: 72 20 31 30 20 74 72 69 65 73 2c 20 73 72 76 3d r 10 tries, srv=
c9c0: 22 20 73 72 76 20 22 2c 20 67 69 76 69 6e 67 20 " srv ", giving
c9d0: 75 70 2e 22 29 29 0a 3b 3b 3b 20 09 09 20 20 20 up.")).;;; ..
c9e0: 23 3b 28 65 72 72 6f 72 20 22 4e 6f 20 73 65 72 #;(error "No ser
c9f0: 76 65 72 20 61 76 61 69 6c 61 62 6c 65 22 29 29 ver available"))
ca00: 29 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 )))))).;;; .;;;
ca10: 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;; ;;=========
ca20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
ca60: 3b 20 3b 3b 20 55 20 54 20 49 20 4c 20 49 20 54 ; ;; U T I L I T
ca70: 20 49 20 45 20 53 20 0a 3b 3b 3b 20 3b 3b 3d 3d I E S .;;; ;;==
ca80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
caa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cac0: 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b ====.;;; .;;; ;;
cad0: 20 67 65 74 20 61 20 73 69 67 6e 61 74 75 72 65 get a signature
cae0: 20 66 6f 72 20 69 64 65 6e 74 69 66 69 6e 67 20 for identifing
caf0: 74 68 69 73 20 70 72 6f 63 65 73 73 0a 3b 3b 3b this process.;;;
cb00: 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 ;;.;;; (define
cb10: 28 67 65 74 2d 70 72 6f 63 65 73 73 2d 73 69 67 (get-process-sig
cb20: 6e 61 74 75 72 65 29 0a 3b 3b 3b 20 20 20 28 63 nature).;;; (c
cb30: 6f 6e 73 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 ons (get-host-na
cb40: 6d 65 29 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 me)(current-proc
cb50: 65 73 73 2d 69 64 29 29 29 0a 3b 3b 3b 20 0a 3b ess-id))).;;; .;
cb60: 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;; ;;===========
cb70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 ===========.;;;
cbb0: 3b 3b 20 53 20 59 20 53 20 54 20 45 20 4d 20 20 ;; S Y S T E M
cbc0: 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3b 20 3b S T U F F.;;; ;
cbd0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
cbe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cbf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cc00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cc10: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b =======.;;; .;;;
cc20: 20 3b 3b 20 67 65 74 20 6e 6f 72 6d 61 6c 69 7a ;; get normaliz
cc30: 65 64 20 63 70 75 20 6c 6f 61 64 20 62 79 20 72 ed cpu load by r
cc40: 65 61 64 69 6e 67 20 66 72 6f 6d 20 2f 70 72 6f eading from /pro
cc50: 63 2f 6c 6f 61 64 61 76 67 20 61 6e 64 0a 3b 3b c/loadavg and.;;
cc60: 3b 20 3b 3b 20 2f 70 72 6f 63 2f 63 70 75 69 6e ; ;; /proc/cpuin
cc70: 66 6f 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 fo return all th
cc80: 72 65 65 20 76 61 6c 75 65 73 20 61 6e 64 20 74 ree values and t
cc90: 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 72 65 61 he number of rea
cca0: 6c 20 63 70 75 73 0a 3b 3b 3b 20 3b 3b 20 61 6e l cpus.;;; ;; an
ccb0: 64 20 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 d the number of
ccc0: 74 68 72 65 61 64 73 20 72 65 74 75 72 6e 73 20 threads returns
ccd0: 61 6c 69 73 74 20 27 28 28 61 64 6a 2d 63 70 75 alist '((adj-cpu
cce0: 2d 6c 6f 61 64 0a 3b 3b 3b 20 3b 3b 20 2e 20 6e -load.;;; ;; . n
ccf0: 6f 72 6d 61 6c 69 7a 65 64 2d 70 72 6f 63 2d 6c ormalized-proc-l
cd00: 6f 61 64 29 20 2e 2e 2e 20 65 74 63 2e 20 20 6b oad) ... etc. k
cd10: 65 79 73 3a 20 61 64 6a 2d 70 72 6f 63 2d 6c 6f eys: adj-proc-lo
cd20: 61 64 2c 0a 3b 3b 3b 20 3b 3b 20 61 64 6a 2d 63 ad,.;;; ;; adj-c
cd30: 6f 72 65 2d 6c 6f 61 64 2c 20 31 6d 2d 6c 6f 61 ore-load, 1m-loa
cd40: 64 2c 20 35 6d 2d 6c 6f 61 64 2c 20 31 35 6d 2d d, 5m-load, 15m-
cd50: 6c 6f 61 64 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 load.;;; ;;.;;;
cd60: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6e 6f 72 (define (get-nor
cd70: 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
cd80: 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 28 28 72 ).;;; (let ((r
cd90: 65 73 20 28 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a es (get-normaliz
cda0: 65 64 2d 63 70 75 2d 6c 6f 61 64 2d 72 61 77 29 ed-cpu-load-raw)
cdb0: 29 0a 3b 3b 3b 20 09 28 64 65 66 61 75 6c 74 20 ).;;; .(default
cdc0: 60 28 28 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 `((adj-proc-load
cdd0: 20 2e 20 32 29 20 3b 3b 20 74 68 65 72 65 20 69 . 2) ;; there i
cde0: 73 20 6e 6f 20 72 69 67 68 74 20 61 6e 73 77 65 s no right answe
cdf0: 72 0a 3b 3b 3b 20 09 09 20 20 20 28 61 64 6a 2d r.;;; .. (adj-
ce00: 63 6f 72 65 2d 6c 6f 61 64 20 2e 20 32 29 0a 3b core-load . 2).;
ce10: 3b 3b 20 09 09 20 20 20 28 31 6d 2d 6c 6f 61 64 ;; .. (1m-load
ce20: 20 20 20 20 20 20 20 2e 20 32 29 0a 3b 3b 3b 20 . 2).;;;
ce30: 09 09 20 20 20 28 35 6d 2d 6c 6f 61 64 20 20 20 .. (5m-load
ce40: 20 20 20 20 2e 20 30 29 20 3b 3b 20 63 61 75 73 . 0) ;; caus
ce50: 65 73 20 61 20 6c 61 72 67 65 20 64 65 6c 74 61 es a large delta
ce60: 20 2d 20 74 68 75 73 20 63 61 75 73 69 6e 67 20 - thus causing
ce70: 64 65 66 61 75 6c 74 20 6f 66 20 74 68 72 6f 74 default of throt
ce80: 74 6c 69 6e 67 20 69 66 20 73 74 75 66 66 20 67 tling if stuff g
ce90: 6f 65 73 20 77 72 6f 6e 67 0a 3b 3b 3b 20 09 09 oes wrong.;;; ..
cea0: 20 20 20 28 31 35 6d 2d 6c 6f 61 64 20 20 20 20 (15m-load
ceb0: 20 20 2e 20 30 29 0a 3b 3b 3b 20 09 09 20 20 20 . 0).;;; ..
cec0: 28 70 72 6f 63 20 20 20 20 20 20 20 20 20 20 2e (proc .
ced0: 20 31 29 0a 3b 3b 3b 20 09 09 20 20 20 28 63 6f 1).;;; .. (co
cee0: 72 65 20 20 20 20 20 20 20 20 20 20 2e 20 31 29 re . 1)
cef0: 0a 3b 3b 3b 20 09 09 20 20 20 28 70 68 79 73 20 .;;; .. (phys
cf00: 20 20 20 20 20 20 20 20 20 2e 20 31 29 0a 3b 3b . 1).;;
cf10: 3b 20 09 09 20 20 20 28 65 72 72 6f 72 20 20 20 ; .. (error
cf20: 20 20 20 20 20 20 2e 20 23 74 29 29 29 29 0a 3b . #t)))).;
cf30: 3b 3b 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b 3b ;; (cond.;;;
cf40: 20 20 20 20 20 20 28 28 61 6e 64 20 28 6c 69 73 ((and (lis
cf50: 74 3f 20 72 65 73 29 0a 3b 3b 3b 20 09 20 20 20 t? res).;;; .
cf60: 28 3e 20 28 6c 65 6e 67 74 68 20 72 65 73 29 20 (> (length res)
cf70: 32 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 72 65 2)).;;; re
cf80: 73 29 0a 3b 3b 3b 20 20 20 20 20 20 28 28 65 71 s).;;; ((eq
cf90: 3f 20 72 65 73 20 23 66 29 20 20 20 64 65 66 61 ? res #f) defa
cfa0: 75 6c 74 29 20 3b 3b 20 61 64 64 20 6d 65 73 73 ult) ;; add mess
cfb0: 61 67 65 73 3f 0a 3b 3b 3b 20 20 20 20 20 20 28 ages?.;;; (
cfc0: 28 65 71 3f 20 72 65 73 20 23 66 29 20 64 65 66 (eq? res #f) def
cfd0: 61 75 6c 74 29 20 20 20 3b 3b 20 74 68 69 73 20 ault) ;; this
cfe0: 77 6f 75 6c 64 20 62 65 20 74 68 65 20 23 65 6f would be the #eo
cff0: 66 0a 3b 3b 3b 20 20 20 20 20 20 28 65 6c 73 65 f.;;; (else
d000: 20 64 65 66 61 75 6c 74 29 29 29 29 0a 3b 3b 3b default)))).;;;
d010: 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 67 .;;; (define (g
d020: 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 et-normalized-cp
d030: 75 2d 6c 6f 61 64 2d 72 61 77 29 0a 3b 3b 3b 20 u-load-raw).;;;
d040: 20 20 28 6c 65 74 2a 20 28 28 61 63 74 75 61 6c (let* ((actual
d050: 2d 68 6f 73 74 20 20 20 20 20 20 20 20 20 20 20 -host
d060: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
d070: 29 20 3b 3b 20 23 66 20 69 73 20 6c 6f 63 61 6c ) ;; #f is local
d080: 68 6f 73 74 0a 3b 3b 3b 20 20 20 20 20 28 6c 65 host.;;; (le
d090: 74 20 28 28 64 61 74 61 20 20 28 61 70 70 65 6e t ((data (appen
d0a0: 64 20 0a 3b 3b 3b 20 09 09 20 20 28 77 69 74 68 d .;;; .. (with
d0b0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 -input-from-file
d0c0: 20 22 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 "/proc/loadavg"
d0d0: 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a 3b 3b 3b read-lines).;;;
d0e0: 20 09 09 20 20 28 77 69 74 68 2d 69 6e 70 75 74 .. (with-input
d0f0: 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f -from-file "/pro
d100: 63 2f 63 70 75 69 6e 66 6f 22 20 72 65 61 64 2d c/cpuinfo" read-
d110: 6c 69 6e 65 73 29 0a 3b 3b 3b 20 09 09 20 20 28 lines).;;; .. (
d120: 6c 69 73 74 20 22 65 6e 64 22 29 29 29 0a 3b 3b list "end"))).;;
d130: 3b 20 09 20 20 28 6c 6f 61 64 2d 72 78 20 20 28 ; . (load-rx (
d140: 72 65 67 65 78 70 20 22 5e 28 5b 5c 5c 64 5c 5c regexp "^([\\d\\
d150: 2e 5d 2b 29 5c 5c 73 2b 28 5b 5c 5c 64 5c 5c 2e .]+)\\s+([\\d\\.
d160: 5d 2b 29 5c 5c 73 2b 28 5b 5c 5c 64 5c 5c 2e 5d ]+)\\s+([\\d\\.]
d170: 2b 29 5c 5c 73 2b 2e 2a 24 22 29 29 0a 3b 3b 3b +)\\s+.*$")).;;;
d180: 20 09 20 20 28 70 72 6f 63 2d 72 78 20 20 28 72 . (proc-rx (r
d190: 65 67 65 78 70 20 22 5e 70 72 6f 63 65 73 73 6f egexp "^processo
d1a0: 72 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 r\\s+:\\s+(\\d+)
d1b0: 5c 5c 73 2a 24 22 29 29 0a 3b 3b 3b 20 09 20 20 \\s*$")).;;; .
d1c0: 28 63 6f 72 65 2d 72 78 20 20 28 72 65 67 65 78 (core-rx (regex
d1d0: 70 20 22 5e 63 6f 72 65 20 69 64 5c 5c 73 2b 3a p "^core id\\s+:
d1e0: 5c 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 \\s+(\\d+)\\s*$"
d1f0: 29 29 0a 3b 3b 3b 20 09 20 20 28 70 68 79 73 2d )).;;; . (phys-
d200: 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 70 68 rx (regexp "^ph
d210: 79 73 69 63 61 6c 20 69 64 5c 5c 73 2b 3a 5c 5c ysical id\\s+:\\
d220: 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 s+(\\d+)\\s*$"))
d230: 0a 3b 3b 3b 20 09 20 20 28 6d 61 78 2d 6e 75 6d .;;; . (max-num
d240: 20 20 28 6c 61 6d 62 64 61 20 28 70 20 6e 29 28 (lambda (p n)(
d250: 6d 61 78 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d max (string->num
d260: 62 65 72 20 70 29 20 6e 29 29 29 29 0a 3b 3b 3b ber p) n)))).;;;
d270: 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ;; (print
d280: 20 22 64 61 74 61 3d 22 20 64 61 74 61 29 0a 3b "data=" data).;
d290: 3b 3b 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 ;; (if (nu
d2a0: 6c 6c 3f 20 64 61 74 61 29 20 3b 3b 20 73 6f 6d ll? data) ;; som
d2b0: 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e ething went wron
d2c0: 67 0a 3b 3b 3b 20 09 20 20 23 66 0a 3b 3b 3b 20 g.;;; . #f.;;;
d2d0: 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 . (let loop ((h
d2e0: 65 64 20 20 20 20 20 20 28 63 61 72 20 64 61 74 ed (car dat
d2f0: 61 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 a)).;;; .. (
d300: 74 61 6c 20 20 20 20 20 20 28 63 64 72 20 64 61 tal (cdr da
d310: 74 61 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 ta)).;;; ..
d320: 28 6c 6f 61 64 73 20 20 20 20 23 66 29 0a 3b 3b (loads #f).;;
d330: 3b 20 09 09 20 20 20 20 20 28 70 72 6f 63 2d 6e ; .. (proc-n
d340: 75 6d 20 30 29 20 20 3b 3b 20 70 72 6f 63 65 73 um 0) ;; proces
d350: 73 6f 72 20 69 6e 63 6c 75 64 65 73 20 74 68 72 sor includes thr
d360: 65 61 64 73 0a 3b 3b 3b 20 09 09 20 20 20 20 20 eads.;;; ..
d370: 28 70 68 79 73 2d 6e 75 6d 20 30 29 20 20 3b 3b (phys-num 0) ;;
d380: 20 70 68 79 73 69 63 61 6c 20 63 68 69 70 20 6f physical chip o
d390: 6e 20 6d 6f 74 68 65 72 62 6f 61 72 64 0a 3b 3b n motherboard.;;
d3a0: 3b 20 09 09 20 20 20 20 20 28 63 6f 72 65 2d 6e ; .. (core-n
d3b0: 75 6d 20 30 29 29 20 3b 3b 20 63 6f 72 65 0a 3b um 0)) ;; core.;
d3c0: 3b 3b 20 09 20 20 20 20 3b 3b 20 28 70 72 69 6e ;; . ;; (prin
d3d0: 74 20 68 65 64 20 22 2c 20 22 20 6c 6f 61 64 73 t hed ", " loads
d3e0: 20 22 2c 20 22 20 70 72 6f 63 2d 6e 75 6d 20 22 ", " proc-num "
d3f0: 2c 20 22 20 70 68 79 73 2d 6e 75 6d 20 22 2c 20 , " phys-num ",
d400: 22 20 63 6f 72 65 2d 6e 75 6d 29 0a 3b 3b 3b 20 " core-num).;;;
d410: 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
d420: 74 61 6c 29 20 3b 3b 20 68 61 76 65 20 61 6c 6c tal) ;; have all
d430: 20 6f 75 72 20 64 61 74 61 2c 20 63 61 6c 63 75 our data, calcu
d440: 6c 61 74 65 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 late normalized
d450: 6c 6f 61 64 20 61 6e 64 20 72 65 74 75 72 6e 20 load and return
d460: 72 65 73 75 6c 74 0a 3b 3b 3b 20 09 09 28 6c 65 result.;;; ..(le
d470: 74 2a 20 28 28 61 63 74 2d 70 72 6f 63 20 28 2b t* ((act-proc (+
d480: 20 70 72 6f 63 2d 6e 75 6d 20 31 29 29 0a 3b 3b proc-num 1)).;;
d490: 3b 20 09 09 20 20 20 20 20 20 20 28 61 63 74 2d ; .. (act-
d4a0: 70 68 79 73 20 28 2b 20 70 68 79 73 2d 6e 75 6d phys (+ phys-num
d4b0: 20 31 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 1)).;;; ..
d4c0: 20 20 28 61 63 74 2d 63 6f 72 65 20 28 2b 20 63 (act-core (+ c
d4d0: 6f 72 65 2d 6e 75 6d 20 31 29 29 0a 3b 3b 3b 20 ore-num 1)).;;;
d4e0: 09 09 20 20 20 20 20 20 20 28 61 64 6a 2d 70 72 .. (adj-pr
d4f0: 6f 63 2d 6c 6f 61 64 20 28 2f 20 28 63 61 72 20 oc-load (/ (car
d500: 6c 6f 61 64 73 29 20 61 63 74 2d 70 72 6f 63 29 loads) act-proc)
d510: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 28 ).;;; .. (
d520: 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 28 2f adj-core-load (/
d530: 20 28 63 61 72 20 6c 6f 61 64 73 29 20 61 63 74 (car loads) act
d540: 2d 63 6f 72 65 29 29 0a 3b 3b 3b 20 09 09 20 20 -core)).;;; ..
d550: 20 20 20 20 20 28 72 65 73 75 6c 74 0a 3b 3b 3b (result.;;;
d560: 20 09 09 09 28 61 70 70 65 6e 64 20 28 6c 69 73 ...(append (lis
d570: 74 20 28 63 6f 6e 73 20 27 61 64 6a 2d 70 72 6f t (cons 'adj-pro
d580: 63 2d 6c 6f 61 64 20 61 64 6a 2d 70 72 6f 63 2d c-load adj-proc-
d590: 6c 6f 61 64 29 0a 3b 3b 3b 20 09 09 09 09 20 20 load).;;; ....
d5a0: 20 20 20 20 28 63 6f 6e 73 20 27 61 64 6a 2d 63 (cons 'adj-c
d5b0: 6f 72 65 2d 6c 6f 61 64 20 61 64 6a 2d 63 6f 72 ore-load adj-cor
d5c0: 65 2d 6c 6f 61 64 29 29 0a 3b 3b 3b 20 09 09 09 e-load)).;;; ...
d5d0: 09 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 31 6d .(list (cons '1m
d5e0: 2d 6c 6f 61 64 20 28 63 61 72 20 6c 6f 61 64 73 -load (car loads
d5f0: 29 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 20 )).;;; ....
d600: 20 28 63 6f 6e 73 20 27 35 6d 2d 6c 6f 61 64 20 (cons '5m-load
d610: 28 63 61 64 72 20 6c 6f 61 64 73 29 29 0a 3b 3b (cadr loads)).;;
d620: 3b 20 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e ; .... (con
d630: 73 20 27 31 35 6d 2d 6c 6f 61 64 20 28 63 61 64 s '15m-load (cad
d640: 64 72 20 6c 6f 61 64 73 29 29 29 0a 3b 3b 3b 20 dr loads))).;;;
d650: 09 09 09 09 28 6c 69 73 74 20 28 63 6f 6e 73 20 ....(list (cons
d660: 27 70 72 6f 63 20 61 63 74 2d 70 72 6f 63 29 0a 'proc act-proc).
d670: 3b 3b 3b 20 09 09 09 09 20 20 20 20 20 20 28 63 ;;; .... (c
d680: 6f 6e 73 20 27 63 6f 72 65 20 61 63 74 2d 63 6f ons 'core act-co
d690: 72 65 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 re).;;; ....
d6a0: 20 20 28 63 6f 6e 73 20 27 70 68 79 73 20 61 63 (cons 'phys ac
d6b0: 74 2d 70 68 79 73 29 29 29 29 29 0a 3b 3b 3b 20 t-phys))))).;;;
d6c0: 09 09 20 20 72 65 73 75 6c 74 29 0a 3b 3b 3b 20 .. result).;;;
d6d0: 09 09 28 72 65 67 65 78 2d 63 61 73 65 0a 3b 3b ..(regex-case.;;
d6e0: 3b 20 09 09 20 20 20 20 68 65 64 0a 3b 3b 3b 20 ; .. hed.;;;
d6f0: 09 09 20 20 28 6c 6f 61 64 2d 72 78 20 20 28 20 .. (load-rx (
d700: 78 20 6c 31 20 6c 35 20 6c 31 35 20 29 20 28 6c x l1 l5 l15 ) (l
d710: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
d720: 72 20 74 61 6c 29 28 6d 61 70 20 73 74 72 69 6e r tal)(map strin
d730: 67 2d 3e 6e 75 6d 62 65 72 20 28 6c 69 73 74 20 g->number (list
d740: 6c 31 20 6c 35 20 6c 31 35 29 29 20 70 72 6f 63 l1 l5 l15)) proc
d750: 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 63 6f -num phys-num co
d760: 72 65 2d 6e 75 6d 29 29 0a 3b 3b 3b 20 09 09 20 re-num)).;;; ..
d770: 20 28 70 72 6f 63 2d 72 78 20 20 28 20 78 20 70 (proc-rx ( x p
d780: 20 20 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 ) (loop
d790: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
d7a0: 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 al) loads
d7b0: 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 70 20 70 (max-num p p
d7c0: 72 6f 63 2d 6e 75 6d 29 20 70 68 79 73 2d 6e 75 roc-num) phys-nu
d7d0: 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 3b 3b 3b m core-num)).;;;
d7e0: 20 09 09 20 20 28 70 68 79 73 2d 72 78 20 20 28 .. (phys-rx (
d7f0: 20 78 20 70 20 20 20 20 20 20 20 20 20 29 20 28 x p ) (
d800: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
d810: 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 dr tal) loads
d820: 20 20 20 20 20 20 20 20 70 72 6f 63 2d 6e 75 6d proc-num
d830: 20 28 6d 61 78 2d 6e 75 6d 20 70 20 70 68 79 73 (max-num p phys
d840: 2d 6e 75 6d 29 20 63 6f 72 65 2d 6e 75 6d 29 29 -num) core-num))
d850: 0a 3b 3b 3b 20 09 09 20 20 28 63 6f 72 65 2d 72 .;;; .. (core-r
d860: 78 20 20 28 20 78 20 63 20 20 20 20 20 20 20 20 x ( x c
d870: 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 ) (loop (car ta
d880: 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 l)(cdr tal) load
d890: 73 20 20 20 20 20 20 20 20 20 20 20 70 72 6f 63 s proc
d8a0: 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 28 6d -num phys-num (m
d8b0: 61 78 2d 6e 75 6d 20 63 20 63 6f 72 65 2d 6e 75 ax-num c core-nu
d8c0: 6d 29 29 29 0a 3b 3b 3b 20 09 09 20 20 28 65 6c m))).;;; .. (el
d8d0: 73 65 20 0a 3b 3b 3b 20 09 09 20 20 20 28 62 65 se .;;; .. (be
d8e0: 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b gin.;;; .. ;
d8f0: 3b 20 28 70 72 69 6e 74 20 22 4e 4f 20 4d 41 54 ; (print "NO MAT
d900: 43 48 3a 20 22 20 68 65 64 29 0a 3b 3b 3b 20 09 CH: " hed).;;; .
d910: 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 . (loop (car
d920: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c tal)(cdr tal) l
d930: 6f 61 64 73 20 70 72 6f 63 2d 6e 75 6d 20 70 68 oads proc-num ph
d940: 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 ys-num core-num)
d950: 29 29 29 29 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b ))))))))).;;; .;
d960: 3b 3b 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d ;; (define (get-
d970: 68 6f 73 74 2d 73 74 61 74 73 20 61 63 66 67 29 host-stats acfg)
d980: 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 28 28 73 74 .;;; (let ((st
d990: 61 74 73 2d 68 61 73 68 20 28 61 72 65 61 2d 73 ats-hash (area-s
d9a0: 74 61 74 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b tats acfg))).;;;
d9b0: 20 20 20 20 20 3b 3b 20 75 73 65 20 74 68 69 73 ;; use this
d9c0: 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 opportunity to
d9d0: 72 65 6d 6f 76 65 20 72 65 66 65 72 65 6e 63 65 remove reference
d9e0: 73 20 74 6f 20 64 62 66 69 6c 65 73 20 77 68 69 s to dbfiles whi
d9f0: 63 68 20 68 61 76 65 20 6e 6f 74 20 62 65 65 6e ch have not been
da00: 20 61 63 63 65 73 73 65 64 20 69 6e 20 61 20 77 accessed in a w
da10: 68 69 6c 65 0a 3b 3b 3b 20 20 20 20 20 28 66 6f hile.;;; (fo
da20: 72 2d 65 61 63 68 0a 3b 3b 3b 20 20 20 20 20 20 r-each.;;;
da30: 28 6c 61 6d 62 64 61 20 28 64 62 6e 61 6d 65 29 (lambda (dbname)
da40: 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 6c 65 74 .;;; (let
da50: 2a 20 28 28 73 74 61 74 73 20 20 20 20 20 20 20 * ((stats
da60: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
da70: 73 74 61 74 73 2d 68 61 73 68 20 64 62 6e 61 6d stats-hash dbnam
da80: 65 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 e)).;;; . (
da90: 6c 61 73 74 2d 61 63 63 65 73 73 20 28 73 74 61 last-access (sta
daa0: 74 2d 77 68 65 6e 20 73 74 61 74 73 29 29 29 0a t-when stats))).
dab0: 3b 3b 3b 20 09 20 28 69 66 20 28 61 6e 64 20 28 ;;; . (if (and (
dac0: 3e 20 6c 61 73 74 2d 61 63 63 65 73 73 20 30 29 > last-access 0)
dad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
daf0: 69 66 20 7a 65 72 6f 20 74 68 65 6e 20 74 68 65 if zero then the
db00: 72 65 20 68 61 73 20 62 65 65 6e 20 6e 6f 20 61 re has been no a
db10: 63 63 65 73 73 0a 3b 3b 3b 20 09 09 20 20 28 3e ccess.;;; .. (>
db20: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
db30: 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 63 65 73 onds) last-acces
db40: 73 29 20 31 30 29 29 20 20 20 20 20 3b 3b 20 6e s) 10)) ;; n
db50: 6f 74 20 75 73 65 64 20 69 6e 20 74 65 6e 20 73 ot used in ten s
db60: 65 63 6f 6e 64 73 0a 3b 3b 3b 20 09 20 20 20 20 econds.;;; .
db70: 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 20 (begin.;;; .
db80: 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 6d 6f (print "Remo
db90: 76 69 6e 67 20 22 20 64 62 6e 61 6d 65 20 22 20 ving " dbname "
dba0: 66 72 6f 6d 20 73 74 61 74 73 20 6c 69 73 74 22 from stats list"
dbb0: 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 68 ).;;; . (h
dbc0: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
dbd0: 21 20 73 74 61 74 73 2d 68 61 73 68 20 64 62 6e ! stats-hash dbn
dbe0: 61 6d 65 29 20 3b 3b 20 72 65 6d 6f 76 65 20 66 ame) ;; remove f
dbf0: 72 6f 6d 20 73 74 61 74 73 20 68 61 73 68 0a 3b rom stats hash.;
dc00: 3b 3b 20 09 20 20 20 20 20 20 20 28 73 74 61 74 ;; . (stat
dc10: 2d 64 62 73 2d 73 65 74 21 20 73 74 61 74 73 20 -dbs-set! stats
dc20: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
dc30: 20 73 74 61 74 73 29 29 29 29 29 29 0a 3b 3b 3b stats)))))).;;;
dc40: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
dc50: 65 2d 6b 65 79 73 20 73 74 61 74 73 2d 68 61 73 e-keys stats-has
dc60: 68 29 29 0a 3b 3b 3b 20 20 20 20 20 0a 3b 3b 3b h)).;;; .;;;
dc70: 20 20 20 20 20 60 28 2c 28 68 61 73 68 2d 74 61 `(,(hash-ta
dc80: 62 6c 65 2d 3e 61 6c 69 73 74 20 28 61 72 65 61 ble->alist (area
dc90: 2d 64 62 73 20 61 63 66 67 29 29 20 3b 3b 20 64 -dbs acfg)) ;; d
dca0: 62 6e 61 6d 65 20 3d 3e 20 72 61 6e 64 6e 75 6d bname => randnum
dcb0: 0a 3b 3b 3b 20 20 20 20 20 20 20 2c 28 6d 61 70 .;;; ,(map
dcc0: 20 28 6c 61 6d 62 64 61 20 28 64 62 6e 61 6d 65 (lambda (dbname
dcd0: 29 20 20 3b 3b 20 64 62 6e 61 6d 65 20 69 73 20 ) ;; dbname is
dce0: 74 68 65 20 64 62 20 6e 61 6d 65 0a 3b 3b 3b 20 the db name.;;;
dcf0: 09 20 20 20 20 20 20 28 63 6f 6e 73 20 64 62 6e . (cons dbn
dd00: 61 6d 65 20 28 73 74 61 74 2d 77 68 65 6e 20 28 ame (stat-when (
dd10: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 hash-table-ref s
dd20: 74 61 74 73 2d 68 61 73 68 20 64 62 6e 61 6d 65 tats-hash dbname
dd30: 29 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 68 )))).;;; . (h
dd40: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 ash-table-keys s
dd50: 74 61 74 73 2d 68 61 73 68 29 29 0a 3b 3b 3b 20 tats-hash)).;;;
dd60: 20 20 20 20 20 20 28 63 70 75 6c 6f 61 64 20 2e (cpuload .
dd70: 20 2c 28 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 ,(get-normalize
dd80: 64 2d 63 70 75 2d 6c 6f 61 64 29 29 29 29 29 0a d-cpu-load))))).
dd90: 3b 3b 3b 20 20 20 20 20 23 3b 28 73 74 61 74 73 ;;; #;(stats
dda0: 20 20 20 2e 20 2c 28 6d 61 70 20 28 6c 61 6d 62 . ,(map (lamb
ddb0: 64 61 20 28 6b 29 20 3b 3b 20 63 72 65 61 74 65 da (k) ;; create
ddc0: 20 61 6e 20 61 6c 69 73 74 20 66 72 6f 6d 20 74 an alist from t
ddd0: 68 65 20 73 74 61 74 73 20 64 61 74 61 0a 3b 3b he stats data.;;
dde0: 3b 20 09 09 20 20 20 20 20 20 20 28 63 6f 6e 73 ; .. (cons
ddf0: 20 6b 20 28 73 74 61 74 2d 3e 61 6c 69 73 74 20 k (stat->alist
de00: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
de10: 28 61 72 65 61 2d 73 74 61 74 73 20 61 63 66 67 (area-stats acfg
de20: 29 20 6b 29 29 29 29 0a 3b 3b 3b 20 09 09 20 20 ) k)))).;;; ..
de30: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b (hash-table-k
de40: 65 79 73 20 28 61 72 65 61 2d 73 74 61 74 73 20 eys (area-stats
de50: 61 63 66 67 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b acfg)))).;;; .;;
de60: 3b 20 23 3b 28 74 72 61 63 65 0a 3b 3b 3b 20 20 ; #;(trace.;;;
de70: 3b 3b 20 61 73 73 76 0a 3b 3b 3b 20 20 3b 3b 20 ;; assv.;;; ;;
de80: 63 64 72 0a 3b 3b 3b 20 20 3b 3b 20 63 61 61 72 cdr.;;; ;; caar
de90: 0a 3b 3b 3b 20 20 3b 3b 20 3b 3b 20 63 64 72 0a .;;; ;; ;; cdr.
dea0: 3b 3b 3b 20 20 3b 3b 20 63 61 6c 6c 0a 3b 3b 3b ;;; ;; call.;;;
deb0: 20 20 3b 3b 20 66 69 6e 61 6c 69 7a 65 2d 61 6c ;; finalize-al
dec0: 6c 2d 64 62 2d 68 61 6e 64 6c 65 73 0a 3b 3b 3b l-db-handles.;;;
ded0: 20 20 3b 3b 20 67 65 74 2d 61 6c 6c 2d 73 65 72 ;; get-all-ser
dee0: 76 65 72 2d 70 6b 74 73 0a 3b 3b 3b 20 20 3b 3b ver-pkts.;;; ;;
def0: 20 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d get-normalized-
df00: 63 70 75 2d 6c 6f 61 64 0a 3b 3b 3b 20 20 3b 3b cpu-load.;;; ;;
df10: 20 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d get-normalized-
df20: 63 70 75 2d 6c 6f 61 64 2d 72 61 77 0a 3b 3b 3b cpu-load-raw.;;;
df30: 20 20 3b 3b 20 6c 61 75 6e 63 68 0a 3b 3b 3b 20 ;; launch.;;;
df40: 20 3b 3b 20 6e 6d 73 67 2d 73 65 6e 64 0a 3b 3b ;; nmsg-send.;;
df50: 3b 20 20 3b 3b 20 70 72 6f 63 65 73 73 2d 64 62 ; ;; process-db
df60: 2d 71 75 65 72 69 65 73 0a 3b 3b 3b 20 20 3b 3b -queries.;;; ;;
df70: 20 72 65 63 65 69 76 65 2d 6d 65 73 73 61 67 65 receive-message
df80: 0a 3b 3b 3b 20 20 3b 3b 20 73 74 64 2d 70 65 65 .;;; ;; std-pee
df90: 72 2d 68 61 6e 64 6c 65 72 0a 3b 3b 3b 20 20 3b r-handler.;;; ;
dfa0: 3b 20 75 70 64 61 74 65 2d 6b 6e 6f 77 6e 2d 73 ; update-known-s
dfb0: 65 72 76 65 72 73 0a 3b 3b 3b 20 20 3b 3b 20 77 ervers.;;; ;; w
dfc0: 6f 72 6b 2d 71 75 65 75 65 2d 70 72 6f 63 65 73 ork-queue-proces
dfd0: 73 6f 72 0a 3b 3b 3b 20 20 29 0a 3b 3b 3b 20 0a sor.;;; ).;;; .
dfe0: 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;; ;;==========
dff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b ============.;;;
e030: 20 3b 3b 20 6e 65 74 75 74 69 6c 0a 3b 3b 3b 20 ;; netutil.;;;
e040: 3b 3b 20 20 20 6d 6f 76 65 20 74 68 69 73 20 62 ;; move this b
e050: 61 63 6b 20 74 6f 20 75 6c 65 78 2d 6e 65 74 75 ack to ulex-netu
e060: 74 69 6c 2e 73 63 6d 20 73 6f 6d 65 64 61 79 3f til.scm someday?
e070: 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;; ;;=========
e080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
e0c0: 3b 20 0a 3b 3b 3b 20 3b 3b 20 23 69 6e 63 6c 75 ; .;;; ;; #inclu
e0d0: 64 65 20 3c 73 74 64 69 6f 2e 68 3e 0a 3b 3b 3b de <stdio.h>.;;;
e0e0: 20 3b 3b 20 23 69 6e 63 6c 75 64 65 20 3c 6e 65 ;; #include <ne
e0f0: 74 69 6e 65 74 2f 69 6e 2e 68 3e 0a 3b 3b 3b 20 tinet/in.h>.;;;
e100: 3b 3b 20 23 69 6e 63 6c 75 64 65 20 3c 73 74 72 ;; #include <str
e110: 69 6e 67 2e 68 3e 0a 3b 3b 3b 20 3b 3b 20 23 69 ing.h>.;;; ;; #i
e120: 6e 63 6c 75 64 65 20 3c 61 72 70 61 2f 69 6e 65 nclude <arpa/ine
e130: 74 2e 68 3e 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 66 t.h>.;;; .;;; (f
e140: 6f 72 65 69 67 6e 2d 64 65 63 6c 61 72 65 20 22 oreign-declare "
e150: 23 69 6e 63 6c 75 64 65 20 5c 22 73 79 73 2f 74 #include \"sys/t
e160: 79 70 65 73 2e 68 5c 22 22 29 0a 3b 3b 3b 20 28 ypes.h\"").;;; (
e170: 66 6f 72 65 69 67 6e 2d 64 65 63 6c 61 72 65 20 foreign-declare
e180: 22 23 69 6e 63 6c 75 64 65 20 5c 22 73 79 73 2f "#include \"sys/
e190: 73 6f 63 6b 65 74 2e 68 5c 22 22 29 0a 3b 3b 3b socket.h\"").;;;
e1a0: 20 28 66 6f 72 65 69 67 6e 2d 64 65 63 6c 61 72 (foreign-declar
e1b0: 65 20 22 23 69 6e 63 6c 75 64 65 20 5c 22 69 66 e "#include \"if
e1c0: 61 64 64 72 73 2e 68 5c 22 22 29 0a 3b 3b 3b 20 addrs.h\"").;;;
e1d0: 28 66 6f 72 65 69 67 6e 2d 64 65 63 6c 61 72 65 (foreign-declare
e1e0: 20 22 23 69 6e 63 6c 75 64 65 20 5c 22 61 72 70 "#include \"arp
e1f0: 61 2f 69 6e 65 74 2e 68 5c 22 22 29 0a 3b 3b 3b a/inet.h\"").;;;
e200: 20 0a 3b 3b 3b 20 3b 3b 20 67 65 74 20 49 50 20 .;;; ;; get IP
e210: 61 64 64 72 65 73 73 65 73 20 66 72 6f 6d 20 41 addresses from A
e220: 4c 4c 20 69 6e 74 65 72 66 61 63 65 73 0a 3b 3b LL interfaces.;;
e230: 3b 20 28 64 65 66 69 6e 65 20 67 65 74 2d 61 6c ; (define get-al
e240: 6c 2d 69 70 73 0a 3b 3b 3b 20 20 20 28 66 6f 72 l-ips.;;; (for
e250: 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 eign-safe-lambda
e260: 2a 20 73 63 68 65 6d 65 2d 6f 62 6a 65 63 74 20 * scheme-object
e270: 28 29 0a 3b 3b 3b 20 20 20 20 20 22 0a 3b 3b 3b ().;;; ".;;;
e280: 20 0a 3b 3b 3b 20 2f 2f 20 66 72 6f 6d 20 68 74 .;;; // from ht
e290: 74 70 73 3a 2f 2f 73 74 61 63 6b 6f 76 65 72 66 tps://stackoverf
e2a0: 6c 6f 77 2e 63 6f 6d 2f 71 75 65 73 74 69 6f 6e low.com/question
e2b0: 73 2f 31 37 39 30 39 34 30 31 2f 6c 69 6e 75 78 s/17909401/linux
e2c0: 2d 63 2d 67 65 74 2d 64 65 66 61 75 6c 74 2d 69 -c-get-default-i
e2d0: 6e 74 65 72 66 61 63 65 73 2d 69 70 2d 61 64 64 nterfaces-ip-add
e2e0: 72 65 73 73 20 3a 0a 3b 3b 3b 20 0a 3b 3b 3b 20 ress :.;;; .;;;
e2f0: 0a 3b 3b 3b 20 20 20 20 20 43 5f 77 6f 72 64 20 .;;; C_word
e300: 6c 73 74 20 3d 20 43 5f 53 43 48 45 4d 45 5f 45 lst = C_SCHEME_E
e310: 4e 44 5f 4f 46 5f 4c 49 53 54 2c 20 6c 65 6e 2c ND_OF_LIST, len,
e320: 20 73 74 72 2c 20 2a 61 3b 0a 3b 3b 3b 20 2f 2f str, *a;.;;; //
e330: 20 20 20 20 73 74 72 75 63 74 20 69 66 61 64 64 struct ifadd
e340: 72 73 20 2a 69 66 61 2c 20 2a 69 3b 0a 3b 3b 3b rs *ifa, *i;.;;;
e350: 20 2f 2f 20 20 20 20 73 74 72 75 63 74 20 73 6f // struct so
e360: 63 6b 61 64 64 72 20 2a 73 61 3b 0a 3b 3b 3b 20 ckaddr *sa;.;;;
e370: 0a 3b 3b 3b 20 20 20 20 20 73 74 72 75 63 74 20 .;;; struct
e380: 69 66 61 64 64 72 73 20 2a 20 69 66 41 64 64 72 ifaddrs * ifAddr
e390: 53 74 72 75 63 74 20 3d 20 4e 55 4c 4c 3b 0a 3b Struct = NULL;.;
e3a0: 3b 3b 20 20 20 20 20 73 74 72 75 63 74 20 69 66 ;; struct if
e3b0: 61 64 64 72 73 20 2a 20 69 66 61 20 3d 20 4e 55 addrs * ifa = NU
e3c0: 4c 4c 3b 0a 3b 3b 3b 20 20 20 20 20 76 6f 69 64 LL;.;;; void
e3d0: 20 2a 20 74 6d 70 41 64 64 72 50 74 72 20 3d 20 * tmpAddrPtr =
e3e0: 4e 55 4c 4c 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 NULL;.;;; .;;;
e3f0: 20 20 20 69 66 20 28 20 67 65 74 69 66 61 64 64 if ( getifadd
e400: 72 73 28 26 69 66 41 64 64 72 53 74 72 75 63 74 rs(&ifAddrStruct
e410: 29 20 21 3d 20 30 29 0a 3b 3b 3b 20 20 20 20 20 ) != 0).;;;
e420: 20 20 43 5f 72 65 74 75 72 6e 28 43 5f 53 43 48 C_return(C_SCH
e430: 45 4d 45 5f 46 41 4c 53 45 29 3b 0a 3b 3b 3b 20 EME_FALSE);.;;;
e440: 0a 3b 3b 3b 20 2f 2f 20 20 20 20 66 6f 72 20 28 .;;; // for (
e450: 69 20 3d 20 69 66 61 3b 20 69 20 21 3d 20 4e 55 i = ifa; i != NU
e460: 4c 4c 3b 20 69 20 3d 20 69 2d 3e 69 66 61 5f 6e LL; i = i->ifa_n
e470: 65 78 74 29 20 7b 0a 3b 3b 3b 20 20 20 20 20 66 ext) {.;;; f
e480: 6f 72 20 28 69 66 61 20 3d 20 69 66 41 64 64 72 or (ifa = ifAddr
e490: 53 74 72 75 63 74 3b 20 69 66 61 20 21 3d 20 4e Struct; ifa != N
e4a0: 55 4c 4c 3b 20 69 66 61 20 3d 20 69 66 61 2d 3e ULL; ifa = ifa->
e4b0: 69 66 61 5f 6e 65 78 74 29 20 7b 0a 3b 3b 3b 20 ifa_next) {.;;;
e4c0: 20 20 20 20 20 20 20 20 69 66 20 28 69 66 61 2d if (ifa-
e4d0: 3e 69 66 61 5f 61 64 64 72 2d 3e 73 61 5f 66 61 >ifa_addr->sa_fa
e4e0: 6d 69 6c 79 3d 3d 41 46 5f 49 4e 45 54 29 20 7b mily==AF_INET) {
e4f0: 20 2f 2f 20 43 68 65 63 6b 20 69 74 20 69 73 0a // Check it is.
e500: 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;;
e510: 2f 2f 20 61 20 76 61 6c 69 64 20 49 50 76 34 20 // a valid IPv4
e520: 61 64 64 72 65 73 73 0a 3b 3b 3b 20 20 20 20 20 address.;;;
e530: 20 20 20 20 20 20 20 20 74 6d 70 41 64 64 72 50 tmpAddrP
e540: 74 72 20 3d 20 26 28 28 73 74 72 75 63 74 20 73 tr = &((struct s
e550: 6f 63 6b 61 64 64 72 5f 69 6e 20 2a 29 69 66 61 ockaddr_in *)ifa
e560: 2d 3e 69 66 61 5f 61 64 64 72 29 2d 3e 73 69 6e ->ifa_addr)->sin
e570: 5f 61 64 64 72 3b 0a 3b 3b 3b 20 20 20 20 20 20 _addr;.;;;
e580: 20 20 20 20 20 20 20 63 68 61 72 20 61 64 64 72 char addr
e590: 65 73 73 42 75 66 66 65 72 5b 49 4e 45 54 5f 41 essBuffer[INET_A
e5a0: 44 44 52 53 54 52 4c 45 4e 5d 3b 0a 3b 3b 3b 20 DDRSTRLEN];.;;;
e5b0: 20 20 20 20 20 20 20 20 20 20 20 20 69 6e 65 74 inet
e5c0: 5f 6e 74 6f 70 28 41 46 5f 49 4e 45 54 2c 20 74 _ntop(AF_INET, t
e5d0: 6d 70 41 64 64 72 50 74 72 2c 20 61 64 64 72 65 mpAddrPtr, addre
e5e0: 73 73 42 75 66 66 65 72 2c 20 49 4e 45 54 5f 41 ssBuffer, INET_A
e5f0: 44 44 52 53 54 52 4c 45 4e 29 3b 0a 3b 3b 3b 20 DDRSTRLEN);.;;;
e600: 2f 2f 20 20 20 20 20 20 20 20 20 20 20 20 70 72 // pr
e610: 69 6e 74 66 28 5c 22 25 73 20 49 50 20 41 64 64 intf(\"%s IP Add
e620: 72 65 73 73 20 25 73 5c 5c 6e 5c 22 2c 20 69 66 ress %s\\n\", if
e630: 61 2d 3e 69 66 61 5f 6e 61 6d 65 2c 20 61 64 64 a->ifa_name, add
e640: 72 65 73 73 42 75 66 66 65 72 29 3b 0a 3b 3b 3b ressBuffer);.;;;
e650: 20 20 20 20 20 20 20 20 20 20 20 20 20 6c 65 6e len
e660: 20 3d 20 73 74 72 6c 65 6e 28 61 64 64 72 65 73 = strlen(addres
e670: 73 42 75 66 66 65 72 29 3b 0a 3b 3b 3b 20 20 20 sBuffer);.;;;
e680: 20 20 20 20 20 20 20 20 20 20 61 20 3d 20 43 5f a = C_
e690: 61 6c 6c 6f 63 28 43 5f 53 49 5a 45 4f 46 5f 50 alloc(C_SIZEOF_P
e6a0: 41 49 52 20 2b 20 43 5f 53 49 5a 45 4f 46 5f 53 AIR + C_SIZEOF_S
e6b0: 54 52 49 4e 47 28 6c 65 6e 29 29 3b 0a 3b 3b 3b TRING(len));.;;;
e6c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 74 72 str
e6d0: 20 3d 20 43 5f 73 74 72 69 6e 67 28 26 61 2c 20 = C_string(&a,
e6e0: 6c 65 6e 2c 20 61 64 64 72 65 73 73 42 75 66 66 len, addressBuff
e6f0: 65 72 29 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 er);.;;;
e700: 20 20 20 20 20 6c 73 74 20 3d 20 43 5f 61 5f 70 lst = C_a_p
e710: 61 69 72 28 26 61 2c 20 73 74 72 2c 20 6c 73 74 air(&a, str, lst
e720: 29 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 7d );.;;; }
e730: 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 2f 2f 20 20 20 .;;; .;;; //
e740: 20 20 20 20 20 65 6c 73 65 20 69 66 20 28 69 66 else if (if
e750: 61 2d 3e 69 66 61 5f 61 64 64 72 2d 3e 73 61 5f a->ifa_addr->sa_
e760: 66 61 6d 69 6c 79 3d 3d 41 46 5f 49 4e 45 54 36 family==AF_INET6
e770: 29 20 7b 20 2f 2f 20 43 68 65 63 6b 20 69 74 20 ) { // Check it
e780: 69 73 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 is.;;; //
e790: 20 20 20 20 20 2f 2f 20 61 20 76 61 6c 69 64 20 // a valid
e7a0: 49 50 76 36 20 61 64 64 72 65 73 73 0a 3b 3b 3b IPv6 address.;;;
e7b0: 20 2f 2f 20 20 20 20 20 20 20 20 20 20 20 20 74 // t
e7c0: 6d 70 41 64 64 72 50 74 72 20 3d 20 26 28 28 73 mpAddrPtr = &((s
e7d0: 74 72 75 63 74 20 73 6f 63 6b 61 64 64 72 5f 69 truct sockaddr_i
e7e0: 6e 36 20 2a 29 69 66 61 2d 3e 69 66 61 5f 61 64 n6 *)ifa->ifa_ad
e7f0: 64 72 29 2d 3e 73 69 6e 36 5f 61 64 64 72 3b 0a dr)->sin6_addr;.
e800: 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 20 20 20 ;;; //
e810: 20 20 63 68 61 72 20 61 64 64 72 65 73 73 42 75 char addressBu
e820: 66 66 65 72 5b 49 4e 45 54 36 5f 41 44 44 52 53 ffer[INET6_ADDRS
e830: 54 52 4c 45 4e 5d 3b 0a 3b 3b 3b 20 2f 2f 20 20 TRLEN];.;;; //
e840: 20 20 20 20 20 20 20 20 20 20 69 6e 65 74 5f 6e inet_n
e850: 74 6f 70 28 41 46 5f 49 4e 45 54 36 2c 20 74 6d top(AF_INET6, tm
e860: 70 41 64 64 72 50 74 72 2c 20 61 64 64 72 65 73 pAddrPtr, addres
e870: 73 42 75 66 66 65 72 2c 20 49 4e 45 54 36 5f 41 sBuffer, INET6_A
e880: 44 44 52 53 54 52 4c 45 4e 29 3b 0a 3b 3b 3b 20 DDRSTRLEN);.;;;
e890: 2f 2f 2f 2f 20 20 20 20 20 20 20 20 20 20 20 20 ////
e8a0: 70 72 69 6e 74 66 28 5c 22 25 73 20 49 50 20 41 printf(\"%s IP A
e8b0: 64 64 72 65 73 73 20 25 73 5c 5c 6e 5c 22 2c 20 ddress %s\\n\",
e8c0: 69 66 61 2d 3e 69 66 61 5f 6e 61 6d 65 2c 20 61 ifa->ifa_name, a
e8d0: 64 64 72 65 73 73 42 75 66 66 65 72 29 3b 0a 3b ddressBuffer);.;
e8e0: 3b 3b 20 2f 2f 20 20 20 20 20 20 20 20 20 20 20 ;; //
e8f0: 20 6c 65 6e 20 3d 20 73 74 72 6c 65 6e 28 61 64 len = strlen(ad
e900: 64 72 65 73 73 42 75 66 66 65 72 29 3b 0a 3b 3b dressBuffer);.;;
e910: 3b 20 2f 2f 20 20 20 20 20 20 20 20 20 20 20 20 ; //
e920: 61 20 3d 20 43 5f 61 6c 6c 6f 63 28 43 5f 53 49 a = C_alloc(C_SI
e930: 5a 45 4f 46 5f 50 41 49 52 20 2b 20 43 5f 53 49 ZEOF_PAIR + C_SI
e940: 5a 45 4f 46 5f 53 54 52 49 4e 47 28 6c 65 6e 29 ZEOF_STRING(len)
e950: 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 );.;;; //
e960: 20 20 20 20 20 73 74 72 20 3d 20 43 5f 73 74 72 str = C_str
e970: 69 6e 67 28 26 61 2c 20 6c 65 6e 2c 20 61 64 64 ing(&a, len, add
e980: 72 65 73 73 42 75 66 66 65 72 29 3b 0a 3b 3b 3b ressBuffer);.;;;
e990: 20 2f 2f 20 20 20 20 20 20 20 20 20 20 20 20 6c // l
e9a0: 73 74 20 3d 20 43 5f 61 5f 70 61 69 72 28 26 61 st = C_a_pair(&a
e9b0: 2c 20 73 74 72 2c 20 6c 73 74 29 3b 0a 3b 3b 3b , str, lst);.;;;
e9c0: 20 2f 2f 20 20 20 20 20 20 20 7d 0a 3b 3b 3b 20 // }.;;;
e9d0: 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 65 6c .;;; // el
e9e0: 73 65 20 7b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 se {.;;; //
e9f0: 20 20 20 20 70 72 69 6e 74 66 28 5c 22 20 6e 6f printf(\" no
ea00: 74 20 61 6e 20 49 50 76 34 20 61 64 64 72 65 73 t an IPv4 addres
ea10: 73 5c 5c 6e 5c 22 29 3b 0a 3b 3b 3b 20 2f 2f 20 s\\n\");.;;; //
ea20: 20 20 20 20 20 20 7d 0a 3b 3b 3b 20 0a 3b 3b 3b }.;;; .;;;
ea30: 20 20 20 20 20 7d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 }.;;; .;;;
ea40: 20 20 20 20 66 72 65 65 69 66 61 64 64 72 73 28 freeifaddrs(
ea50: 69 66 61 29 3b 0a 3b 3b 3b 20 20 20 20 20 43 5f ifa);.;;; C_
ea60: 72 65 74 75 72 6e 28 6c 73 74 29 3b 0a 3b 3b 3b return(lst);.;;;
ea70: 20 0a 3b 3b 3b 20 22 29 29 0a 3b 3b 3b 20 0a 3b .;;; ")).;;; .;
ea80: 3b 3b 20 3b 3b 20 43 68 61 6e 67 65 20 74 68 69 ;; ;; Change thi
ea90: 73 20 74 6f 20 62 69 61 73 20 66 6f 72 20 61 64 s to bias for ad
eaa0: 64 72 65 73 73 65 73 20 77 69 74 68 20 61 20 72 dresses with a r
eab0: 65 61 73 6f 6e 61 62 6c 65 20 62 72 6f 61 64 63 easonable broadc
eac0: 61 73 74 20 76 61 6c 75 65 3f 0a 3b 3b 3b 20 3b ast value?.;;; ;
ead0: 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 69 ;.;;; (define (i
eae0: 70 2d 70 72 65 66 2d 6c 65 73 73 3f 20 61 20 62 p-pref-less? a b
eaf0: 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 ).;;; (let* ((
eb00: 72 61 74 65 20 28 6c 61 6d 62 64 61 20 28 69 70 rate (lambda (ip
eb10: 73 74 72 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 str).;;;
eb20: 20 20 20 20 20 20 20 20 20 20 28 72 65 67 65 78 (regex
eb30: 2d 63 61 73 65 20 69 70 73 74 72 0a 3b 3b 3b 20 -case ipstr.;;;
eb40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
eb50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 20 22 ( "
eb60: 5e 31 32 37 5c 5c 2e 22 20 5f 20 30 20 29 0a 3b ^127\\." _ 0 ).;
eb70: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
eb80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
eb90: 28 20 22 5e 28 31 30 5c 5c 2e 30 7c 31 39 32 5c ( "^(10\\.0|192\
eba0: 5c 2e 31 36 38 5c 5c 2e 29 5c 5c 2e 2e 2a 22 20 \.168\\.)\\..*"
ebb0: 5f 20 31 20 29 0a 3b 3b 3b 20 20 20 20 20 20 20 _ 1 ).;;;
ebc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ebd0: 20 20 20 20 20 20 20 28 20 65 6c 73 65 20 32 20 ( else 2
ebe0: 29 20 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 ) )))).;;; (
ebf0: 3c 20 28 72 61 74 65 20 61 29 20 28 72 61 74 65 < (rate a) (rate
ec00: 20 62 29 29 29 29 0a 3b 3b 3b 20 20 20 0a 3b 3b b)))).;;; .;;
ec10: 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ; .;;; (define (
ec20: 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 get-my-best-addr
ec30: 65 73 73 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 ess).;;; (let
ec40: 28 28 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 ((all-my-address
ec50: 65 73 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 es (get-all-ips)
ec60: 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 3b 3b ).;;; ;;
ec70: 28 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 (all-my-addresse
ec80: 73 2d 6f 6c 64 20 28 76 65 63 74 6f 72 2d 3e 6c s-old (vector->l
ec90: 69 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 ist (hostinfo-ad
eca0: 64 72 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d dresses (hostnam
ecb0: 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 28 67 65 74 e->hostinfo (get
ecc0: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 29 29 0a -host-name))))).
ecd0: 3b 3b 3b 20 20 20 20 20 20 20 20 20 29 0a 3b 3b ;;; ).;;
ece0: 3b 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 ; (cond.;;;
ecf0: 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 61 6c 6c ((null? all
ed00: 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 0a 3b -my-addresses).;
ed10: 3b 3b 20 20 20 20 20 20 20 28 67 65 74 2d 68 6f ;; (get-ho
ed20: 73 74 2d 6e 61 6d 65 29 29 20 20 20 20 20 20 20 st-name))
ed30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ed40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ed50: 20 20 20 3b 3b 20 6e 6f 20 69 6e 74 65 72 66 61 ;; no interfa
ed60: 63 65 73 3f 0a 3b 3b 3b 20 20 20 20 20 20 28 28 ces?.;;; ((
ed70: 65 71 3f 20 28 6c 65 6e 67 74 68 20 61 6c 6c 2d eq? (length all-
ed80: 6d 79 2d 61 64 64 72 65 73 73 65 73 29 20 31 29 my-addresses) 1)
ed90: 0a 3b 3b 3b 20 20 20 20 20 20 20 28 63 61 72 20 .;;; (car
eda0: 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 all-my-addresses
edb0: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
edc0: 20 20 20 20 20 20 20 20 3b 3b 20 6f 6e 6c 79 20 ;; only
edd0: 6f 6e 65 20 74 6f 20 63 68 6f 6f 73 65 20 66 72 one to choose fr
ede0: 6f 6d 2c 20 6a 75 73 74 20 67 6f 20 77 69 74 68 om, just go with
edf0: 20 69 74 0a 3b 3b 3b 20 20 20 20 20 20 0a 3b 3b it.;;; .;;
ee00: 3b 20 20 20 20 20 20 28 65 6c 73 65 0a 3b 3b 3b ; (else.;;;
ee10: 20 20 20 20 20 20 20 28 63 61 72 20 28 73 6f 72 (car (sor
ee20: 74 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 t all-my-address
ee30: 65 73 20 69 70 2d 70 72 65 66 2d 6c 65 73 73 3f es ip-pref-less?
ee40: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 3b 3b 20 ))).;;; ;;
ee50: 28 65 6c 73 65 20 0a 3b 3b 3b 20 20 20 20 20 20 (else .;;;
ee60: 3b 3b 20 20 28 69 70 2d 3e 73 74 72 69 6e 67 20 ;; (ip->string
ee70: 28 63 61 72 20 28 66 69 6c 74 65 72 20 28 6c 61 (car (filter (la
ee80: 6d 62 64 61 20 28 78 29 20 20 20 20 20 20 20 20 mbda (x)
ee90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
eea0: 20 74 61 6b 65 20 61 6e 79 20 62 75 74 20 31 32 take any but 12
eeb0: 37 2e 0a 3b 3b 3b 20 20 20 20 20 20 3b 3b 20 20 7..;;; ;;
eec0: 20 20 09 09 09 20 28 6e 6f 74 20 28 65 71 3f 20 ... (not (eq?
eed0: 28 75 38 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (u8vector-ref x
eee0: 30 29 20 31 32 37 29 29 29 0a 3b 3b 3b 20 20 20 0) 127))).;;;
eef0: 20 20 20 3b 3b 20 20 20 20 09 09 20 20 20 20 20 ;; ..
ef00: 20 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 all-my-address
ef10: 65 73 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 es)))).;;; .;;;
ef20: 20 20 20 20 20 29 29 29 0a 3b 3b 3b 20 0a 3b 3b ))).;;; .;;
ef30: 3b 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d 61 ; (define (get-a
ef40: 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 29 0a 3b ll-ips-sorted).;
ef50: 3b 3b 20 20 20 28 73 6f 72 74 20 28 67 65 74 2d ;; (sort (get-
ef60: 61 6c 6c 2d 69 70 73 29 20 69 70 2d 70 72 65 66 all-ips) ip-pref
ef70: 2d 6c 65 73 73 3f 29 29 0a 3b 3b 3b 20 0a 3b 3b -less?)).;;; .;;
ef80: 3b 20 0a 29 0a ; .).