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 0a 28 6d 6f ox sqlite3)..(mo
0510: 64 75 6c 65 20 75 6c 65 78 0a 20 20 20 20 2a 0a dule ulex. *.
0520: 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 20 .(import scheme
0530: 70 6f 73 69 78 20 63 68 69 63 6b 65 6e 20 64 61 posix chicken da
0540: 74 61 2d 73 74 72 75 63 74 75 72 65 73 20 70 6f ta-structures po
0550: 72 74 73 20 65 78 74 72 61 73 20 66 69 6c 65 73 rts extras files
0560: 20 6d 61 69 6c 62 6f 78 29 0a 28 69 6d 70 6f 72 mailbox).(impor
0570: 74 20 73 72 66 69 2d 31 38 20 70 6b 74 73 20 6d t srfi-18 pkts m
0580: 61 74 63 68 61 62 6c 65 20 72 65 67 65 78 0a 09 atchable regex..
0590: 74 79 70 65 64 2d 72 65 63 6f 72 64 73 20 73 72 typed-records sr
05a0: 66 69 2d 36 39 20 73 72 66 69 2d 31 0a 09 73 72 fi-69 srfi-1..sr
05b0: 66 69 2d 34 20 72 65 67 65 78 2d 63 61 73 65 0a fi-4 regex-case.
05c0: 09 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 .(prefix sqlite3
05d0: 20 73 71 6c 69 74 65 33 3a 29 0a 09 66 6f 72 65 sqlite3:)..fore
05e0: 69 67 6e 0a 09 74 63 70 36 0a 09 3b 3b 20 75 6c ign..tcp6..;; ul
05f0: 65 78 2d 6e 65 74 75 74 69 6c 0a 09 68 6f 73 74 ex-netutil..host
0600: 69 6e 66 6f 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d info)..;;=======
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
0650: 3b 3b 20 6e 65 74 77 6f 72 6b 20 75 74 69 6c 69 ;; network utili
0660: 74 69 65 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ties.;;=========
0670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
06b0: 64 65 66 69 6e 65 20 28 72 61 74 65 2d 69 70 20 define (rate-ip
06c0: 69 70 61 64 64 72 29 0a 20 20 28 72 65 67 65 78 ipaddr). (regex
06d0: 2d 63 61 73 65 20 69 70 61 64 64 72 0a 20 20 20 -case ipaddr.
06e0: 20 28 20 22 5e 31 32 37 5c 5c 2e 2e 2a 22 20 5f ( "^127\\..*" _
06f0: 20 30 20 29 0a 20 20 20 20 28 20 22 5e 28 31 30 0 ). ( "^(10
0700: 5c 5c 2e 30 7c 31 39 32 5c 5c 2e 31 36 38 29 5c \\.0|192\\.168)\
0710: 5c 2e 2e 2a 22 20 5f 20 31 20 29 0a 20 20 20 20 \..*" _ 1 ).
0720: 28 20 65 6c 73 65 20 32 20 29 20 29 29 0a 0a 3b ( else 2 ) ))..;
0730: 3b 20 43 68 61 6e 67 65 20 74 68 69 73 20 74 6f ; Change this to
0740: 20 62 69 61 73 20 66 6f 72 20 61 64 64 72 65 73 bias for addres
0750: 73 65 73 20 77 69 74 68 20 61 20 72 65 61 73 6f ses with a reaso
0760: 6e 61 62 6c 65 20 62 72 6f 61 64 63 61 73 74 20 nable broadcast
0770: 76 61 6c 75 65 3f 0a 3b 3b 0a 28 64 65 66 69 6e value?.;;.(defin
0780: 65 20 28 69 70 2d 70 72 65 66 2d 6c 65 73 73 3f e (ip-pref-less?
0790: 20 61 20 62 29 0a 20 20 28 3e 20 28 72 61 74 65 a b). (> (rate
07a0: 2d 69 70 20 61 29 20 28 72 61 74 65 2d 69 70 20 -ip a) (rate-ip
07b0: 62 29 29 29 0a 20 20 0a 0a 28 64 65 66 69 6e 65 b))). ..(define
07c0: 20 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 (get-my-best-ad
07d0: 64 72 65 73 73 29 0a 20 20 28 6c 65 74 20 28 28 dress). (let ((
07e0: 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 all-my-addresses
07f0: 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 29 29 0a (get-all-ips)).
0800: 20 20 20 20 20 20 20 20 3b 3b 28 61 6c 6c 2d 6d ;;(all-m
0810: 79 2d 61 64 64 72 65 73 73 65 73 2d 6f 6c 64 20 y-addresses-old
0820: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 (vector->list (h
0830: 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 ostinfo-addresse
0840: 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 s (hostname->hos
0850: 74 69 6e 66 6f 20 28 67 65 74 2d 68 6f 73 74 2d tinfo (get-host-
0860: 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 20 20 20 name))))).
0870: 20 20 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 ). (cond.
0880: 20 20 20 28 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d ((null? all-m
0890: 79 2d 61 64 64 72 65 73 73 65 73 29 0a 20 20 20 y-addresses).
08a0: 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d (get-host-nam
08b0: 65 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 e))
08c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
08d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
08e0: 6e 6f 20 69 6e 74 65 72 66 61 63 65 73 3f 0a 20 no interfaces?.
08f0: 20 20 20 20 28 28 65 71 3f 20 28 6c 65 6e 67 74 ((eq? (lengt
0900: 68 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 h all-my-address
0910: 65 73 29 20 31 29 0a 20 20 20 20 20 20 28 63 61 es) 1). (ca
0920: 72 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 r all-my-address
0930: 65 73 29 29 20 20 20 20 20 20 20 20 20 20 20 20 es))
0940: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 6e 6c ;; onl
0950: 79 20 6f 6e 65 20 74 6f 20 63 68 6f 6f 73 65 20 y one to choose
0960: 66 72 6f 6d 2c 20 6a 75 73 74 20 67 6f 20 77 69 from, just go wi
0970: 74 68 20 69 74 0a 20 20 20 20 20 0a 20 20 20 20 th it. .
0980: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 63 61 (else. (ca
0990: 72 20 28 73 6f 72 74 20 61 6c 6c 2d 6d 79 2d 61 r (sort all-my-a
09a0: 64 64 72 65 73 73 65 73 20 69 70 2d 70 72 65 66 ddresses ip-pref
09b0: 2d 6c 65 73 73 3f 29 29 29 0a 20 20 20 20 20 3b -less?))). ;
09c0: 3b 20 28 65 6c 73 65 20 0a 20 20 20 20 20 3b 3b ; (else . ;;
09d0: 20 20 28 69 70 2d 3e 73 74 72 69 6e 67 20 28 63 (ip->string (c
09e0: 61 72 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ar (filter (lamb
09f0: 64 61 20 28 78 29 20 20 20 20 20 20 20 20 20 20 da (x)
0a00: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
0a10: 61 6b 65 20 61 6e 79 20 62 75 74 20 31 32 37 2e ake any but 127.
0a20: 0a 20 20 20 20 20 3b 3b 20 20 20 20 09 09 09 20 . ;; ...
0a30: 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 (not (eq? (u8vec
0a40: 74 6f 72 2d 72 65 66 20 78 20 30 29 20 31 32 37 tor-ref x 0) 127
0a50: 29 29 29 0a 20 20 20 20 20 3b 3b 20 20 20 20 09 ))). ;; .
0a60: 09 20 20 20 20 20 20 20 61 6c 6c 2d 6d 79 2d 61 . all-my-a
0a70: 64 64 72 65 73 73 65 73 29 29 29 29 0a 0a 20 20 ddresses))))..
0a80: 20 20 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 )))..(define
0a90: 28 67 65 74 2d 61 6c 6c 2d 69 70 73 2d 73 6f 72 (get-all-ips-sor
0aa0: 74 65 64 29 0a 20 20 28 73 6f 72 74 20 28 67 65 ted). (sort (ge
0ab0: 74 2d 61 6c 6c 2d 69 70 73 29 20 69 70 2d 70 72 t-all-ips) ip-pr
0ac0: 65 66 2d 6c 65 73 73 3f 29 29 0a 0a 28 64 65 66 ef-less?))..(def
0ad0: 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 ine (get-all-ips
0ae0: 29 0a 20 20 28 6d 61 70 20 69 70 2d 3e 73 74 72 ). (map ip->str
0af0: 69 6e 67 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 ing (vector->lis
0b00: 74 20 0a 09 09 20 20 20 28 68 6f 73 74 69 6e 66 t ... (hostinf
0b10: 6f 2d 61 64 64 72 65 73 73 65 73 0a 09 09 20 20 o-addresses...
0b20: 20 20 28 68 6f 73 74 2d 69 6e 66 6f 72 6d 61 74 (host-informat
0b30: 69 6f 6e 20 28 63 75 72 72 65 6e 74 2d 68 6f 73 ion (current-hos
0b40: 74 6e 61 6d 65 29 29 29 29 29 29 0a 0a 3b 3b 20 tname))))))..;;
0b50: 6d 61 6b 65 20 69 74 20 61 20 67 6c 6f 62 61 6c make it a global
0b60: 3f 20 57 65 6c 6c 2c 20 69 74 20 69 73 20 6c 6f ? Well, it is lo
0b70: 63 61 6c 20 74 6f 20 61 72 65 61 20 6d 6f 64 75 cal to area modu
0b80: 6c 65 0a 0a 28 64 65 66 69 6e 65 20 2a 63 61 70 le..(define *cap
0b90: 74 61 69 6e 2d 70 6b 74 73 70 65 63 2a 0a 20 20 tain-pktspec*.
0ba0: 60 28 28 63 61 70 74 61 69 6e 20 28 68 6f 73 74 `((captain (host
0bb0: 20 20 20 20 20 2e 20 68 29 0a 09 20 20 20 20 20 . h)..
0bc0: 28 70 6f 72 74 20 20 20 20 20 2e 20 70 29 0a 09 (port . p)..
0bd0: 20 20 20 20 20 28 70 69 64 20 20 20 20 20 20 2e (pid .
0be0: 20 69 29 0a 09 20 20 20 20 20 28 69 70 61 64 64 i).. (ipadd
0bf0: 72 20 20 20 2e 20 61 29 0a 09 20 20 20 20 20 29 r . a).. )
0c00: 0a 20 20 20 20 23 3b 28 64 61 74 61 20 20 20 28 . #;(data (
0c10: 68 6f 73 74 6e 61 6d 65 20 2e 20 68 29 20 20 3b hostname . h) ;
0c20: 3b 20 73 65 6e 64 65 72 20 68 6f 73 74 6e 61 6d ; sender hostnam
0c30: 65 0a 09 20 20 20 20 28 70 6f 72 74 20 20 20 20 e.. (port
0c40: 20 2e 20 70 29 20 20 3b 3b 20 73 65 6e 64 65 72 . p) ;; sender
0c50: 20 70 6f 72 74 0a 09 20 20 20 20 28 69 70 61 64 port.. (ipad
0c60: 64 72 20 20 20 2e 20 61 29 20 20 3b 3b 20 73 65 dr . a) ;; se
0c70: 6e 64 65 72 20 69 70 0a 09 20 20 20 20 28 68 6f nder ip.. (ho
0c80: 73 74 6b 65 79 20 20 2e 20 6b 29 20 20 3b 3b 20 stkey . k) ;;
0c90: 73 65 6e 64 69 6e 67 20 68 6f 73 74 20 6b 65 79 sending host key
0ca0: 20 2d 20 73 74 6f 72 65 20 69 6e 66 6f 20 61 74 - store info at
0cb0: 20 73 65 72 76 65 72 20 75 6e 64 65 72 20 74 68 server under th
0cc0: 69 73 20 6b 65 79 0a 09 20 20 20 20 28 73 65 72 is key.. (ser
0cd0: 76 6b 65 79 20 20 2e 20 73 29 20 20 3b 3b 20 73 vkey . s) ;; s
0ce0: 65 72 76 65 72 20 6b 65 79 20 2d 20 74 68 69 73 erver key - this
0cf0: 20 6e 65 65 64 73 20 74 6f 20 6d 61 74 63 68 20 needs to match
0d00: 61 74 20 73 65 72 76 65 72 20 65 6e 64 20 6f 72 at server end or
0d10: 20 72 65 6a 65 63 74 20 74 68 65 20 6d 73 67 0a reject the msg.
0d20: 09 20 20 20 20 28 66 6f 72 6d 61 74 20 20 20 2e . (format .
0d30: 20 66 29 20 20 3b 3b 20 73 62 3d 73 65 72 69 61 f) ;; sb=seria
0d40: 6c 69 7a 65 64 2d 62 61 73 65 36 34 2c 20 74 3d lized-base64, t=
0d50: 74 65 78 74 2c 20 73 78 3d 73 65 78 70 72 2c 20 text, sx=sexpr,
0d60: 6a 3d 6a 73 6f 6e 0a 09 20 20 20 20 28 64 61 74 j=json.. (dat
0d70: 61 20 20 20 20 20 2e 20 64 29 20 20 3b 3b 20 62 a . d) ;; b
0d80: 61 73 65 36 34 20 65 6e 63 6f 64 65 64 20 73 6c ase64 encoded sl
0d90: 6c 6e 20 64 61 74 61 0a 09 20 20 20 20 29 29 29 ln data.. )))
0da0: 0a 0a 3b 3b 20 73 74 72 75 63 74 20 66 6f 72 20 ..;; struct for
0db0: 6b 65 65 70 69 6e 67 20 74 72 61 63 6b 20 6f 66 keeping track of
0dc0: 20 6f 75 72 20 77 6f 72 6c 64 0a 0a 28 64 65 66 our world..(def
0dd0: 73 74 72 75 63 74 20 75 64 61 74 0a 20 20 28 63 struct udat. (c
0de0: 61 70 74 61 69 6e 2d 61 64 64 72 65 73 73 20 23 aptain-address #
0df0: 66 29 0a 20 20 28 63 61 70 74 61 69 6e 2d 68 6f f). (captain-ho
0e00: 73 74 20 20 20 20 23 66 29 0a 20 20 28 63 61 70 st #f). (cap
0e10: 74 61 69 6e 2d 70 6f 72 74 20 20 20 20 23 66 29 tain-port #f)
0e20: 0a 20 20 28 63 61 70 74 61 69 6e 2d 70 69 64 20 . (captain-pid
0e30: 20 20 20 20 23 66 29 0a 20 20 28 63 70 6b 74 73 #f). (cpkts
0e40: 2d 64 69 72 20 20 20 20 20 20 20 28 63 6f 6e 63 -dir (conc
0e50: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
0e60: 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 t-variable "HOME
0e70: 22 29 20 22 2f 2e 75 6c 65 78 2f 70 6b 74 73 22 ") "/.ulex/pkts"
0e80: 29 29 0a 20 20 28 63 70 6b 74 2d 73 70 65 63 20 )). (cpkt-spec
0e90: 20 20 20 20 20 20 2a 63 61 70 74 61 69 6e 2d 70 *captain-p
0ea0: 6b 74 73 70 65 63 2a 29 0a 20 20 28 6d 79 2d 63 ktspec*). (my-c
0eb0: 70 6b 74 2d 6b 65 79 20 20 20 20 20 23 66 29 20 pkt-key #f)
0ec0: 20 20 3b 3b 20 70 75 74 20 5a 20 63 61 72 64 20 ;; put Z card
0ed0: 68 65 72 65 20 77 68 65 6e 20 49 20 63 72 65 61 here when I crea
0ee0: 74 65 20 61 20 70 6b 74 20 66 6f 72 20 6d 79 73 te a pkt for mys
0ef0: 65 6c 66 20 61 73 20 63 61 70 74 61 69 6e 0a 20 elf as captain.
0f00: 20 28 6d 79 2d 61 64 64 72 65 73 73 20 20 20 20 (my-address
0f10: 20 20 23 66 29 0a 20 20 28 6d 79 2d 68 6f 73 74 #f). (my-host
0f20: 6e 61 6d 65 20 20 20 20 20 23 66 29 0a 20 20 28 name #f). (
0f30: 6d 79 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 my-port
0f40: 23 66 29 0a 20 20 28 6d 79 2d 70 69 64 20 20 20 #f). (my-pid
0f50: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
0f60: 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 20 20 28 process-id)). (
0f70: 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 20 20 20 serv-listener
0f80: 23 66 29 0a 20 20 28 68 61 6e 64 6c 65 72 2d 74 #f). (handler-t
0f90: 68 72 65 61 64 20 20 23 66 29 0a 20 20 28 68 61 hread #f). (ha
0fa0: 6e 64 6c 65 72 73 20 20 20 20 20 20 20 20 27 28 ndlers '(
0fb0: 29 29 0a 20 20 28 6f 75 74 67 6f 69 6e 67 2d 63 )). (outgoing-c
0fc0: 6f 6e 6e 73 20 20 28 6d 61 6b 65 2d 68 61 73 68 onns (make-hash
0fd0: 2d 74 61 62 6c 65 29 29 20 20 3b 3b 20 68 6f 73 -table)) ;; hos
0fe0: 74 3a 70 6f 72 74 20 2d 3e 20 63 6f 6e 6e 0a 20 t:port -> conn.
0ff0: 20 29 0a 0a 3b 3b 20 73 74 72 75 63 74 20 66 6f )..;; struct fo
1000: 72 20 6b 65 65 70 69 6e 67 20 74 72 61 63 6b 20 r keeping track
1010: 6f 66 20 6f 74 68 65 72 73 20 77 65 20 61 72 65 of others we are
1020: 20 74 61 6c 6b 69 6e 67 20 74 6f 0a 0a 28 64 65 talking to..(de
1030: 66 73 74 72 75 63 74 20 70 65 65 72 0a 20 20 28 fstruct peer. (
1040: 61 64 64 72 2d 70 6f 72 74 20 20 20 20 20 20 20 addr-port
1050: 23 66 29 0a 20 20 28 68 6f 73 74 6e 61 6d 65 20 #f). (hostname
1060: 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 70 69 #f). (pi
1070: 64 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 d #f
1080: 29 0a 20 20 28 69 6e 70 20 20 20 20 20 20 20 20 ). (inp
1090: 20 20 20 20 20 23 66 29 20 20 3b 3b 20 69 6e 70 #f) ;; inp
10a0: 75 74 20 70 6f 72 74 20 66 72 6f 6d 20 74 68 65 ut port from the
10b0: 20 70 65 65 72 0a 20 20 28 6f 75 70 20 20 20 20 peer. (oup
10c0: 20 20 20 20 20 20 20 20 20 23 66 29 20 20 3b 3b #f) ;;
10d0: 20 6f 75 74 70 75 74 20 70 6f 72 74 20 74 6f 20 output port to
10e0: 74 68 65 20 70 65 65 72 0a 20 20 28 6f 77 6e 73 the peer. (owns
10f0: 20 20 20 20 20 20 20 20 20 20 20 20 27 28 29 29 '())
1100: 20 3b 3b 20 6c 69 73 74 20 6f 66 20 64 61 74 61 ;; list of data
1110: 62 61 73 65 73 20 74 68 69 73 20 70 65 65 72 20 bases this peer
1120: 69 73 20 63 75 72 72 65 6e 74 6c 79 20 68 61 6e is currently han
1130: 64 6c 69 6e 67 0a 20 20 29 0a 0a 3b 3b 3d 3d 3d dling. )..;;===
1140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1180: 3d 3d 3d 0a 3b 3b 20 43 61 70 74 61 69 6e 20 70 ===.;; Captain p
1190: 6b 74 20 66 75 6e 63 74 69 6f 6e 73 0a 3b 3b 3d kt functions.;;=
11a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11e0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 67 69 76 65 6e 20 =====..;; given
11f0: 61 20 70 6b 74 73 20 64 69 72 20 72 65 61 64 20 a pkts dir read
1200: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 67 65 74 .;;.(define (get
1210: 2d 61 6c 6c 2d 63 61 70 74 61 69 6e 2d 70 6b 74 -all-captain-pkt
1220: 73 20 75 64 61 74 61 29 0a 20 20 28 6c 65 74 2a s udata). (let*
1230: 20 28 28 70 6b 74 73 64 69 72 20 20 20 20 20 20 ((pktsdir
1240: 20 28 6c 65 74 20 28 28 64 20 28 75 64 61 74 2d (let ((d (udat-
1250: 63 70 6b 74 73 2d 64 69 72 20 75 64 61 74 61 29 cpkts-dir udata)
1260: 29 29 0a 09 09 09 20 20 28 69 66 20 28 66 69 6c )).... (if (fil
1270: 65 2d 65 78 69 73 74 73 3f 20 64 29 0a 09 09 09 e-exists? d)....
1280: 20 20 20 20 20 20 64 0a 09 09 09 20 20 20 20 20 d....
1290: 20 28 62 65 67 69 6e 0a 09 09 09 09 28 63 72 65 (begin.....(cre
12a0: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 64 20 ate-directory d
12b0: 23 74 29 0a 09 09 09 09 64 29 29 29 29 0a 09 20 #t).....d))))..
12c0: 28 61 6c 6c 2d 70 6b 74 2d 66 69 6c 65 73 20 28 (all-pkt-files (
12d0: 67 6c 6f 62 20 28 63 6f 6e 63 20 70 6b 74 73 64 glob (conc pktsd
12e0: 69 72 20 22 2f 2a 2e 70 6b 74 22 29 29 29 0a 09 ir "/*.pkt")))..
12f0: 20 28 70 6b 74 2d 73 70 65 63 20 20 20 20 20 20 (pkt-spec
1300: 28 75 64 61 74 2d 63 70 6b 74 2d 73 70 65 63 20 (udat-cpkt-spec
1310: 75 64 61 74 61 29 29 29 0a 20 20 20 20 28 6d 61 udata))). (ma
1320: 70 20 28 6c 61 6d 62 64 61 20 28 70 6b 74 2d 66 p (lambda (pkt-f
1330: 69 6c 65 29 0a 09 20 20 20 28 72 65 61 64 2d 70 ile).. (read-p
1340: 6b 74 2d 3e 61 6c 69 73 74 20 70 6b 74 2d 66 69 kt->alist pkt-fi
1350: 6c 65 20 70 6b 74 73 70 65 63 3a 20 70 6b 74 2d le pktspec: pkt-
1360: 73 70 65 63 29 29 0a 09 20 61 6c 6c 2d 70 6b 74 spec)).. all-pkt
1370: 2d 66 69 6c 65 73 29 29 29 0a 0a 3b 3b 20 73 6f -files)))..;; so
1380: 72 74 20 62 79 20 44 20 74 68 65 6e 20 5a 2c 20 rt by D then Z,
1390: 72 65 74 75 72 6e 20 6f 6e 65 2c 20 63 68 6f 6f return one, choo
13a0: 73 65 20 74 68 65 20 6f 6c 64 65 73 74 20 74 68 se the oldest th
13b0: 65 6e 0a 3b 3b 20 64 69 66 66 65 72 65 6e 74 69 en.;; differenti
13c0: 61 74 65 20 69 66 20 6e 65 65 64 65 64 20 75 73 ate if needed us
13d0: 69 6e 67 20 74 68 65 20 5a 20 6b 65 79 0a 3b 3b ing the Z key.;;
13e0: 6c 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 77 l.(define (get-w
13f0: 69 6e 6e 69 6e 67 2d 70 6b 74 20 70 6b 74 73 29 inning-pkt pkts)
1400: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 6b . (if (null? pk
1410: 74 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 ts). #f.
1420: 20 20 20 28 63 61 72 20 28 73 6f 72 74 20 70 6b (car (sort pk
1430: 74 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 ts (lambda (a b)
1440: 0a 09 09 09 28 6c 65 74 20 28 28 61 64 20 28 73 ....(let ((ad (s
1450: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 61 tring->number (a
1460: 6c 69 73 74 2d 72 65 66 20 27 44 20 61 29 29 29 list-ref 'D a)))
1470: 0a 09 09 09 20 20 20 20 20 20 28 62 64 20 28 73 .... (bd (s
1480: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 61 tring->number (a
1490: 6c 69 73 74 2d 72 65 66 20 27 44 20 62 29 29 29 list-ref 'D b)))
14a0: 29 0a 09 09 09 20 20 28 69 66 20 28 65 71 3f 20 ).... (if (eq?
14b0: 61 20 62 29 0a 09 09 09 20 20 20 20 20 20 28 6c a b).... (l
14c0: 65 74 20 28 28 61 7a 20 28 61 6c 69 73 74 2d 72 et ((az (alist-r
14d0: 65 66 20 27 5a 20 61 29 29 0a 09 09 09 09 20 20 ef 'Z a)).....
14e0: 20 20 28 62 7a 20 28 61 6c 69 73 74 2d 72 65 66 (bz (alist-ref
14f0: 20 27 5a 20 62 29 29 29 0a 09 09 09 09 28 73 74 'Z b))).....(st
1500: 72 69 6e 67 3e 3d 3f 20 61 7a 20 62 7a 29 29 0a ring>=? az bz)).
1510: 09 09 09 20 20 20 20 20 20 28 3e 20 61 64 20 62 ... (> ad b
1520: 64 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 63 72 d))))))))..;; cr
1530: 65 61 74 65 20 61 20 74 63 70 20 6c 69 73 74 65 eate a tcp liste
1540: 6e 65 72 20 61 6e 64 20 72 65 74 75 72 6e 20 61 ner and return a
1550: 20 70 6f 70 75 6c 61 74 65 64 20 75 64 61 74 20 populated udat
1560: 73 74 72 75 63 74 20 77 69 74 68 0a 3b 3b 20 6d struct with.;; m
1570: 79 20 70 6f 72 74 2c 20 61 64 64 72 65 73 73 2c y port, address,
1580: 20 68 6f 73 74 6e 61 6d 65 2c 20 70 69 64 20 65 hostname, pid e
1590: 74 63 2e 0a 3b 3b 20 72 65 74 75 72 6e 20 23 66 tc..;; return #f
15a0: 20 69 66 20 66 61 69 6c 20 74 6f 20 66 69 6e 64 if fail to find
15b0: 20 61 20 70 6f 72 74 20 74 6f 20 61 6c 6c 6f 63 a port to alloc
15c0: 61 74 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ate..;;.(define
15d0: 28 73 74 61 72 74 2d 73 65 72 76 65 72 2d 66 69 (start-server-fi
15e0: 6e 64 2d 70 6f 72 74 20 75 64 61 74 61 20 23 21 nd-port udata #!
15f0: 6f 70 74 69 6f 6e 61 6c 20 28 70 6f 72 74 20 34 optional (port 4
1600: 32 34 32 29 29 20 0a 20 20 28 68 61 6e 64 6c 65 242)) . (handle
1610: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
1620: 20 20 65 78 6e 0a 20 20 20 20 20 20 28 69 66 20 exn. (if
1630: 28 3c 20 70 6f 72 74 20 36 35 35 33 35 29 28 63 (< port 65535)(c
1640: 6f 6e 6e 65 63 74 2d 73 65 72 76 65 72 2d 66 69 onnect-server-fi
1650: 6e 64 2d 70 6f 72 74 20 75 64 61 74 61 20 28 2b nd-port udata (+
1660: 20 70 6f 72 74 20 31 29 29 20 23 66 29 0a 20 20 port 1)) #f).
1670: 20 20 28 63 6f 6e 6e 65 63 74 2d 73 65 72 76 65 (connect-serve
1680: 72 20 75 64 61 74 61 20 70 6f 72 74 29 29 29 0a r udata port))).
1690: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 6e 65 63 .(define (connec
16a0: 74 2d 73 65 72 76 65 72 20 75 64 61 74 61 20 70 t-server udata p
16b0: 6f 72 74 29 0a 20 20 3b 3b 20 28 74 63 70 2d 6c ort). ;; (tcp-l
16c0: 69 73 74 65 6e 65 72 2d 73 6f 63 6b 65 74 20 4c istener-socket L
16d0: 49 53 54 45 4e 45 52 29 28 73 6f 63 6b 65 74 2d ISTENER)(socket-
16e0: 6e 61 6d 65 20 73 6f 29 0a 20 20 3b 3b 20 73 6f name so). ;; so
16f0: 63 6b 61 64 64 72 2d 61 64 64 72 65 73 73 2c 20 ckaddr-address,
1700: 73 6f 63 6b 61 64 64 72 2d 70 6f 72 74 2c 20 73 sockaddr-port, s
1710: 6f 63 6b 61 64 64 72 2d 3e 73 74 72 69 6e 67 0a ockaddr->string.
1720: 20 20 28 6c 65 74 2a 20 28 28 74 6c 73 6e 20 28 (let* ((tlsn (
1730: 74 63 70 2d 6c 69 73 74 65 6e 20 70 6f 72 74 20 tcp-listen port
1740: 31 30 30 30 20 23 66 29 29 20 3b 3b 20 28 74 63 1000 #f)) ;; (tc
1750: 70 2d 6c 69 73 74 65 6e 20 54 43 50 50 4f 52 54 p-listen TCPPORT
1760: 20 5b 42 41 43 4b 4c 4f 47 20 5b 48 4f 53 54 5d [BACKLOG [HOST]
1770: 5d 29 0a 09 20 28 61 64 64 72 20 28 67 65 74 2d ]).. (addr (get-
1780: 6d 79 2d 62 65 73 74 2d 61 64 64 72 65 73 73 29 my-best-address)
1790: 29 29 20 3b 3b 20 28 68 6f 73 74 69 6e 66 6f 2d )) ;; (hostinfo-
17a0: 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 74 2d addresses (host-
17b0: 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 63 75 72 information (cur
17c0: 72 65 6e 74 2d 68 6f 73 74 6e 61 6d 65 29 29 29 rent-hostname)))
17d0: 0a 20 20 20 20 28 75 64 61 74 2d 6d 79 2d 61 64 . (udat-my-ad
17e0: 64 72 65 73 73 2d 73 65 74 21 20 20 20 20 75 64 dress-set! ud
17f0: 61 74 61 20 61 64 64 72 29 0a 20 20 20 20 28 75 ata addr). (u
1800: 64 61 74 2d 6d 79 2d 70 6f 72 74 2d 73 65 74 21 dat-my-port-set!
1810: 20 20 20 20 20 20 20 75 64 61 74 61 20 70 6f 72 udata por
1820: 74 29 0a 20 20 20 20 28 75 64 61 74 2d 6d 79 2d t). (udat-my-
1830: 68 6f 73 74 6e 61 6d 65 2d 73 65 74 21 20 20 20 hostname-set!
1840: 75 64 61 74 61 20 28 67 65 74 2d 68 6f 73 74 2d udata (get-host-
1850: 6e 61 6d 65 29 29 0a 20 20 20 20 28 75 64 61 74 name)). (udat
1860: 2d 73 65 72 76 2d 6c 69 73 74 65 6e 65 72 2d 73 -serv-listener-s
1870: 65 74 21 20 75 64 61 74 61 20 74 6c 73 6e 29 0a et! udata tlsn).
1880: 20 20 20 20 75 64 61 74 61 29 29 0a 0a 3b 3b 20 udata))..;;
1890: 70 75 74 20 74 68 65 20 68 6f 73 74 2c 20 69 70 put the host, ip
18a0: 2c 20 70 6f 72 74 20 61 6e 64 20 70 69 64 20 69 , port and pid i
18b0: 6e 74 6f 20 61 20 70 6b 74 20 69 6e 0a 3b 3b 20 nto a pkt in.;;
18c0: 74 68 65 20 63 61 70 74 61 69 6e 20 70 6b 74 73 the captain pkts
18d0: 20 64 69 72 0a 3b 3b 20 20 2d 20 61 73 73 75 6d dir.;; - assum
18e0: 65 73 20 75 73 65 72 20 68 61 73 20 61 6c 72 65 es user has alre
18f0: 61 64 79 20 66 69 72 65 64 20 75 70 20 61 20 73 ady fired up a s
1900: 65 72 76 65 72 0a 3b 3b 20 20 20 20 77 68 69 63 erver.;; whic
1910: 68 20 77 69 6c 6c 20 62 65 20 69 6e 20 74 68 65 h will be in the
1920: 20 75 64 61 74 61 20 73 74 72 75 63 74 0a 3b 3b udata struct.;;
1930: 0a 28 64 65 66 69 6e 65 20 28 63 72 65 61 74 65 .(define (create
1940: 2d 63 61 70 74 61 69 6e 2d 70 6b 74 20 75 64 61 -captain-pkt uda
1950: 74 61 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 ta). (if (not (
1960: 75 64 61 74 2d 73 65 72 76 2d 6c 69 73 74 65 6e udat-serv-listen
1970: 65 72 20 75 64 61 74 61 29 29 0a 20 20 20 20 20 er udata)).
1980: 20 28 62 65 67 69 6e 0a 09 28 70 72 69 6e 74 20 (begin..(print
1990: 22 45 52 52 4f 52 3a 20 63 72 65 61 74 65 2d 63 "ERROR: create-c
19a0: 61 70 74 61 69 6e 2d 70 6b 74 20 63 61 6c 6c 65 aptain-pkt calle
19b0: 64 20 77 69 74 68 20 6f 75 74 20 61 20 6c 69 73 d with out a lis
19c0: 74 65 6e 65 72 22 29 0a 09 23 66 29 0a 20 20 20 tener")..#f).
19d0: 20 20 20 28 6c 65 74 2a 20 28 28 70 6b 74 64 61 (let* ((pktda
19e0: 74 20 60 28 28 70 6f 72 74 20 20 20 2e 20 2c 28 t `((port . ,(
19f0: 75 64 61 74 2d 6d 79 2d 70 6f 72 74 20 75 64 61 udat-my-port uda
1a00: 74 61 29 29 0a 09 09 20 20 20 20 20 20 20 28 68 ta))... (h
1a10: 6f 73 74 20 20 20 2e 20 2c 28 75 64 61 74 2d 6d ost . ,(udat-m
1a20: 79 2d 68 6f 73 74 6e 61 6d 65 20 75 64 61 74 61 y-hostname udata
1a30: 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 70 61 ))... (ipa
1a40: 64 64 72 20 2e 20 2c 28 75 64 61 74 2d 6d 79 2d ddr . ,(udat-my-
1a50: 61 64 64 72 65 73 73 20 75 64 61 74 61 29 29 0a address udata)).
1a60: 09 09 20 20 20 20 20 20 20 28 70 69 64 20 20 20 .. (pid
1a70: 20 2e 20 2c 28 75 64 61 74 2d 6d 79 2d 70 69 64 . ,(udat-my-pid
1a80: 20 20 20 20 20 75 64 61 74 61 29 29 29 29 0a 09 udata))))..
1a90: 20 20 20 20 20 28 70 6b 74 64 69 72 20 20 28 75 (pktdir (u
1aa0: 64 61 74 2d 63 70 6b 74 73 2d 64 69 72 20 75 64 dat-cpkts-dir ud
1ab0: 61 74 61 29 29 0a 09 20 20 20 20 20 28 70 6b 74 ata)).. (pkt
1ac0: 73 70 65 63 20 28 75 64 61 74 2d 63 70 6b 74 2d spec (udat-cpkt-
1ad0: 73 70 65 63 20 75 64 61 74 61 29 29 0a 09 20 20 spec udata))..
1ae0: 20 20 20 29 0a 09 28 75 64 61 74 2d 6d 79 2d 63 )..(udat-my-c
1af0: 70 6b 74 2d 6b 65 79 2d 73 65 74 21 0a 09 20 75 pkt-key-set!.. u
1b00: 64 61 74 61 0a 09 20 28 77 72 69 74 65 2d 61 6c data.. (write-al
1b10: 69 73 74 2d 3e 70 6b 74 0a 09 20 20 70 6b 74 64 ist->pkt.. pktd
1b20: 69 72 0a 09 20 20 70 6b 74 64 61 74 0a 09 20 20 ir.. pktdat..
1b30: 70 6b 74 73 70 65 63 3a 20 70 6b 74 73 70 65 63 pktspec: pktspec
1b40: 0a 09 20 20 70 74 79 70 65 3a 20 20 20 27 63 61 .. ptype: 'ca
1b50: 70 74 61 69 6e 29 29 0a 09 28 75 64 61 74 2d 6d ptain))..(udat-m
1b60: 79 2d 63 70 6b 74 2d 6b 65 79 20 75 64 61 74 61 y-cpkt-key udata
1b70: 29 29 29 29 0a 0a 3b 3b 20 4e 42 2f 2f 20 54 68 ))))..;; NB// Th
1b80: 69 73 20 6e 65 65 64 73 20 74 6f 20 62 65 20 73 is needs to be s
1b90: 74 61 72 74 65 64 20 69 6e 20 61 20 74 68 72 65 tarted in a thre
1ba0: 61 64 0a 3b 3b 0a 3b 3b 20 73 65 74 75 70 20 74 ad.;;.;; setup t
1bb0: 6f 20 62 65 20 61 20 63 61 70 74 61 69 6e 0a 3b o be a captain.;
1bc0: 3b 20 20 20 2d 20 73 74 61 72 74 20 73 65 72 76 ; - start serv
1bd0: 65 72 0a 3b 3b 20 20 20 2d 20 63 72 65 61 74 65 er.;; - create
1be0: 20 70 6b 74 0a 3b 3b 20 20 20 2d 20 73 74 61 72 pkt.;; - star
1bf0: 74 20 73 65 72 76 65 72 20 70 6f 72 74 20 68 61 t server port ha
1c00: 6e 64 6c 65 72 0a 3b 3b 0a 28 64 65 66 69 6e 65 ndler.;;.(define
1c10: 20 28 73 65 74 75 70 2d 61 73 2d 63 61 70 74 61 (setup-as-capta
1c20: 69 6e 20 75 64 61 74 61 29 0a 20 20 28 69 66 20 in udata). (if
1c30: 28 73 74 61 72 74 2d 73 65 72 76 65 72 2d 66 69 (start-server-fi
1c40: 6e 64 2d 70 6f 72 74 20 75 64 61 74 61 29 20 3b nd-port udata) ;
1c50: 3b 20 70 75 74 73 20 74 68 65 20 73 65 72 76 65 ; puts the serve
1c60: 72 20 69 6e 20 75 64 61 74 61 0a 20 20 20 20 20 r in udata.
1c70: 20 28 69 66 20 28 63 72 65 61 74 65 2d 63 61 70 (if (create-cap
1c80: 74 61 69 6e 2d 70 6b 74 20 75 64 61 74 61 29 0a tain-pkt udata).
1c90: 09 20 20 28 6c 65 74 2a 20 28 28 74 68 20 28 6d . (let* ((th (m
1ca0: 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
1cb0: 64 61 20 28 29 0a 09 09 09 09 20 20 20 20 28 75 da ()..... (u
1cc0: 6c 65 78 2d 68 61 6e 64 6c 65 72 20 75 64 61 74 lex-handler udat
1cd0: 61 29 29 20 22 43 61 70 74 61 69 6e 20 68 61 6e a)) "Captain han
1ce0: 64 6c 65 72 22 29 29 29 0a 09 20 20 20 20 28 75 dler"))).. (u
1cf0: 64 61 74 2d 68 61 6e 64 6c 65 72 2d 74 68 72 65 dat-handler-thre
1d00: 61 64 2d 73 65 74 21 20 75 64 61 74 61 20 74 68 ad-set! udata th
1d10: 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 ).. (thread-s
1d20: 74 61 72 74 21 20 74 68 29 29 0a 09 20 20 23 66 tart! th)).. #f
1d30: 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 28 64 ). #f))..(d
1d40: 65 66 69 6e 65 20 28 67 65 74 2d 70 65 65 72 2d efine (get-peer-
1d50: 64 61 74 20 75 64 61 74 61 20 68 6f 73 74 2d 70 dat udata host-p
1d60: 6f 72 74 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 ort #!optional (
1d70: 68 6f 73 74 6e 61 6d 65 20 23 66 29 28 70 69 64 hostname #f)(pid
1d80: 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 #f)). (let* ((
1d90: 70 64 61 74 20 28 6f 72 20 28 68 61 73 68 2d 74 pdat (or (hash-t
1da0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1db0: 20 28 75 64 61 74 2d 6f 75 74 67 6f 69 6e 67 2d (udat-outgoing-
1dc0: 63 6f 6e 6e 73 20 75 64 61 74 61 29 20 68 6f 73 conns udata) hos
1dd0: 74 2d 70 6f 72 74 20 23 66 29 0a 09 09 20 20 20 t-port #f)...
1de0: 28 6c 65 74 20 28 28 6e 70 64 61 74 20 28 6d 61 (let ((npdat (ma
1df0: 6b 65 2d 70 65 65 72 20 61 64 64 72 2d 70 6f 72 ke-peer addr-por
1e00: 74 3a 20 68 6f 73 74 2d 70 6f 72 74 29 29 29 0a t: host-port))).
1e10: 09 09 20 20 20 20 20 28 69 66 20 68 6f 73 74 6e .. (if hostn
1e20: 61 6d 65 20 28 70 65 65 72 2d 68 6f 73 74 6e 61 ame (peer-hostna
1e30: 6d 65 2d 73 65 74 21 20 6e 70 64 61 74 20 68 6f me-set! npdat ho
1e40: 73 74 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 20 stname))...
1e50: 28 69 66 20 70 69 64 20 28 70 65 65 72 2d 70 69 (if pid (peer-pi
1e60: 64 2d 73 65 74 21 20 6e 70 64 61 74 20 70 69 64 d-set! npdat pid
1e70: 29 29 0a 09 09 20 20 20 20 20 28 6c 65 74 2d 76 ))... (let-v
1e80: 61 6c 75 65 73 20 28 28 28 6e 69 6e 70 20 6e 6f alues (((ninp no
1e90: 75 70 29 28 74 63 70 2d 63 6f 6e 6e 65 63 74 20 up)(tcp-connect
1ea0: 68 6f 73 74 2d 70 6f 72 74 29 29 29 0a 09 09 20 host-port)))...
1eb0: 20 20 20 20 20 20 28 70 65 65 72 2d 69 6e 70 2d (peer-inp-
1ec0: 73 65 74 21 20 6e 70 64 61 74 20 6e 69 6e 70 29 set! npdat ninp)
1ed0: 0a 09 09 20 20 20 20 20 20 20 28 70 65 65 72 2d ... (peer-
1ee0: 6f 75 70 2d 73 65 74 21 20 6e 70 64 61 74 20 6e oup-set! npdat n
1ef0: 6f 75 70 29 29 0a 09 09 20 20 20 20 20 28 68 61 oup))... (ha
1f00: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 75 sh-table-set! (u
1f10: 64 61 74 2d 6f 75 74 67 6f 69 6e 67 2d 63 6f 6e dat-outgoing-con
1f20: 6e 73 20 75 64 61 74 61 29 20 68 6f 73 74 2d 70 ns udata) host-p
1f30: 6f 72 74 20 6e 70 64 61 74 29 0a 09 09 20 20 20 ort npdat)...
1f40: 20 20 6e 70 64 61 74 29 29 29 29 0a 20 20 20 20 npdat)))).
1f50: 70 64 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 pdat))..(define
1f60: 28 67 65 74 2d 70 65 65 72 2d 70 6f 72 74 73 20 (get-peer-ports
1f70: 75 64 61 74 61 20 68 6f 73 74 2d 70 6f 72 74 20 udata host-port
1f80: 68 6f 73 74 6e 61 6d 65 20 70 69 64 29 0a 20 20 hostname pid).
1f90: 28 6c 65 74 20 28 28 70 64 61 74 20 28 67 65 74 (let ((pdat (get
1fa0: 2d 70 65 65 72 2d 64 61 74 20 75 64 61 74 61 20 -peer-dat udata
1fb0: 68 6f 73 74 2d 70 6f 72 74 20 68 6f 73 74 6e 61 host-port hostna
1fc0: 6d 65 20 70 69 64 29 29 29 0a 20 20 20 20 28 76 me pid))). (v
1fd0: 61 6c 75 65 73 20 28 70 65 65 72 2d 69 6e 70 20 alues (peer-inp
1fe0: 70 64 61 74 29 28 70 65 65 72 2d 6f 75 70 20 70 pdat)(peer-oup p
1ff0: 64 61 74 29 29 29 29 0a 0a 3b 3b 20 73 65 6e 64 dat))))..;; send
2000: 20 62 61 63 6b 20 61 63 6b 0a 3b 3b 0a 28 64 65 back ack.;;.(de
2010: 66 69 6e 65 20 28 73 65 6e 64 2d 61 63 6b 20 75 fine (send-ack u
2020: 64 61 74 61 20 71 72 79 6b 65 79 20 6f 75 70 29 data qrykey oup)
2030: 0a 20 20 28 77 72 69 74 65 2d 6c 69 6e 65 20 28 . (write-line (
2040: 63 6f 6e 63 0a 09 20 20 20 20 20 20 20 22 61 63 conc.. "ac
2050: 6b 20 22 0a 09 20 20 20 20 20 20 20 28 75 64 61 k ".. (uda
2060: 74 2d 6d 79 2d 61 64 64 72 65 73 73 20 20 75 64 t-my-address ud
2070: 61 74 61 29 20 22 3a 22 20 28 75 64 61 74 2d 6d ata) ":" (udat-m
2080: 79 2d 70 6f 72 74 20 75 64 61 74 61 29 20 22 20 y-port udata) "
2090: 22 0a 09 20 20 20 20 20 20 20 28 75 64 61 74 2d ".. (udat-
20a0: 6d 79 2d 68 6f 73 74 6e 61 6d 65 20 75 64 61 74 my-hostname udat
20b0: 61 29 20 22 20 22 0a 09 20 20 20 20 20 20 20 28 a) " ".. (
20c0: 75 64 61 74 2d 6d 79 2d 70 69 64 20 20 20 20 20 udat-my-pid
20d0: 20 75 64 61 74 61 29 20 22 20 22 0a 09 20 20 20 udata) " "..
20e0: 20 20 20 20 71 72 79 6b 65 79 29 0a 09 20 20 20 qrykey)..
20f0: 20 20 20 6f 75 70 29 0a 20 20 28 77 72 69 74 65 oup). (write
2100: 2d 6c 69 6e 65 20 71 72 79 6b 65 79 20 6f 75 70 -line qrykey oup
2110: 29 29 20 3b 3b 20 77 65 20 6d 75 73 74 20 73 65 )) ;; we must se
2120: 6e 64 20 61 20 73 65 63 6f 6e 64 20 6c 69 6e 65 nd a second line
2130: 20 2d 20 66 6f 72 20 74 68 65 20 61 63 6b 20 6c - for the ack l
2140: 65 74 20 69 74 20 62 65 20 74 68 65 20 71 72 79 et it be the qry
2150: 6b 65 79 20 0a 20 20 0a 3b 3b 20 0a 3b 3b 0a 28 key . .;; .;;.(
2160: 64 65 66 69 6e 65 20 28 75 6c 65 78 2d 68 61 6e define (ulex-han
2170: 64 6c 65 72 20 75 64 61 74 61 29 0a 20 20 28 6c dler udata). (l
2180: 65 74 2a 20 28 28 73 65 72 76 2d 6c 69 73 74 65 et* ((serv-liste
2190: 6e 65 72 20 28 75 64 61 74 2d 73 65 72 76 2d 6c ner (udat-serv-l
21a0: 69 73 74 65 6e 65 72 20 75 64 61 74 61 29 29 29 istener udata)))
21b0: 0a 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 . (let-values
21c0: 20 28 28 28 69 6e 70 20 6f 75 70 29 28 74 63 70 (((inp oup)(tcp
21d0: 2d 61 63 63 65 70 74 20 73 65 72 76 2d 6c 69 73 -accept serv-lis
21e0: 74 65 6e 65 72 29 29 29 0a 20 20 20 20 20 20 3b tener))). ;
21f0: 3b 20 64 61 74 61 20 63 6f 6d 65 73 20 61 73 20 ; data comes as
2200: 74 77 6f 20 6c 69 6e 65 73 0a 20 20 20 20 20 20 two lines.
2210: 3b 3b 20 20 20 68 61 6e 64 6c 65 72 6b 65 79 20 ;; handlerkey
2220: 72 65 73 70 2d 61 64 64 72 3a 72 65 73 70 2d 70 resp-addr:resp-p
2230: 6f 72 74 20 68 6f 73 74 6e 61 6d 65 20 70 69 64 ort hostname pid
2240: 20 71 72 79 6b 65 79 20 5b 64 62 70 61 74 68 2f qrykey [dbpath/
2250: 64 62 66 69 6c 65 2e 64 62 5d 0a 20 20 20 20 20 dbfile.db].
2260: 20 3b 3b 20 20 20 64 61 74 61 0a 20 20 20 20 20 ;; data.
2270: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 74 61 (let loop ((sta
2280: 74 65 20 27 73 74 61 72 74 29 29 0a 09 28 6c 65 te 'start))..(le
2290: 74 2a 20 28 28 63 6f 6e 74 72 6f 6c 64 61 74 20 t* ((controldat
22a0: 28 72 65 61 64 2d 6c 69 6e 65 20 69 6e 70 29 29 (read-line inp))
22b0: 0a 09 20 20 20 20 20 20 20 28 64 61 74 61 20 20 .. (data
22c0: 20 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 20 (read-line
22d0: 69 6e 70 29 29 29 0a 09 20 20 28 6d 61 74 63 68 inp))).. (match
22e0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 63 (string-split c
22f0: 6f 6e 74 72 6f 6c 64 61 74 29 0a 09 20 20 20 20 ontroldat)..
2300: 28 28 68 61 6e 64 6c 65 72 6b 65 79 20 68 6f 73 ((handlerkey hos
2310: 74 3a 70 6f 72 74 20 68 6f 73 74 6e 61 6d 65 20 t:port hostname
2320: 70 69 64 20 71 72 79 6b 65 79 20 70 61 72 61 6d pid qrykey param
2330: 73 20 2e 2e 2e 29 0a 09 20 20 20 20 20 28 63 61 s ...).. (ca
2340: 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 se (string->symb
2350: 6f 6c 20 68 61 6e 64 6c 65 72 6b 65 79 29 0a 09 ol handlerkey)..
2360: 20 20 20 20 20 20 20 28 65 6c 73 65 0a 09 09 28 (else...(
2370: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 70 69 let-values (((pi
2380: 6e 70 20 70 6f 75 70 29 28 67 65 74 2d 70 65 65 np poup)(get-pee
2390: 72 2d 70 6f 72 74 73 20 75 64 61 74 61 20 68 6f r-ports udata ho
23a0: 73 74 3a 70 6f 72 74 20 68 6f 73 74 6e 61 6d 65 st:port hostname
23b0: 20 70 69 64 29 29 29 0a 09 09 20 20 28 73 65 6e pid)))... (sen
23c0: 64 2d 61 63 6b 20 75 64 61 74 61 20 71 72 79 6b d-ack udata qryk
23d0: 65 79 20 70 6f 75 70 29 29 0a 09 09 28 61 64 64 ey poup))...(add
23e0: 2d 74 6f 2d 77 6f 72 6b 2d 71 75 65 75 65 20 28 -to-work-queue (
23f0: 67 65 74 2d 70 65 65 72 2d 64 61 74 20 75 64 61 get-peer-dat uda
2400: 74 61 20 68 6f 73 74 3a 70 6f 72 74 29 20 68 61 ta host:port) ha
2410: 6e 64 6c 65 72 6b 65 79 20 64 61 74 61 29 29 29 ndlerkey data)))
2420: 29 0a 09 20 20 20 20 28 65 6c 73 65 20 28 70 72 ).. (else (pr
2430: 69 6e 74 20 22 42 41 44 20 44 41 54 41 3f 20 68 int "BAD DATA? h
2440: 61 6e 64 6c 65 72 3d 22 20 68 61 6e 64 6c 65 72 andler=" handler
2450: 20 22 20 64 61 74 61 3d 22 20 64 61 74 61 29 29 " data=" data))
2460: 29 29 0a 09 28 6c 6f 6f 70 20 73 74 61 74 65 29 ))..(loop state)
2470: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
2480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
24c0: 3b 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 73 65 74 ; connection set
24d0: 75 70 20 61 6e 64 20 6d 61 6e 61 67 65 6d 65 6e up and managemen
24e0: 74 20 66 75 6e 63 74 69 6f 6e 73 0a 3b 3b 3d 3d t functions.;;==
24f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2530: 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 6e 64 20 6f 72 ====..;; find or
2540: 20 62 65 63 6f 6d 65 20 74 68 65 20 63 61 70 74 become the capt
2550: 61 69 6e 2c 20 72 65 74 75 72 6e 20 61 20 75 6c ain, return a ul
2560: 65 78 20 6f 62 6a 65 63 74 0a 3b 3b 0a 28 64 65 ex object.;;.(de
2570: 66 69 6e 65 20 28 73 65 74 75 70 29 0a 20 20 28 fine (setup). (
2580: 6c 65 74 2a 20 28 28 75 64 61 74 61 20 28 6d 61 let* ((udata (ma
2590: 6b 65 2d 75 64 61 74 29 29 0a 09 20 28 63 70 6b ke-udat)).. (cpk
25a0: 74 73 20 28 67 65 74 2d 61 6c 6c 2d 63 61 70 74 ts (get-all-capt
25b0: 61 69 6e 2d 70 6b 74 73 20 75 64 61 74 61 29 29 ain-pkts udata))
25c0: 20 3b 3b 20 72 65 61 64 20 63 61 70 74 61 69 6e ;; read captain
25d0: 20 70 6b 74 73 0a 09 20 28 63 61 70 74 6e 20 28 pkts.. (captn (
25e0: 67 65 74 2d 77 69 6e 6e 69 6e 67 2d 70 6b 74 20 get-winning-pkt
25f0: 63 70 6b 74 73 29 29 29 0a 20 20 20 20 28 69 66 cpkts))). (if
2600: 20 63 61 70 74 6e 0a 09 28 6c 65 74 2a 20 28 28 captn..(let* ((
2610: 70 6f 72 74 20 20 20 28 61 6c 69 73 74 2d 72 65 port (alist-re
2620: 66 20 27 70 6f 72 74 20 20 20 63 61 70 74 6e 29 f 'port captn)
2630: 29 0a 09 20 20 20 20 20 20 20 28 68 6f 73 74 20 ).. (host
2640: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 68 6f (alist-ref 'ho
2650: 73 74 20 20 20 63 61 70 74 6e 29 29 0a 09 20 20 st captn))..
2660: 20 20 20 20 20 28 69 70 61 64 64 72 20 28 61 6c (ipaddr (al
2670: 69 73 74 2d 72 65 66 20 27 69 70 61 64 64 72 20 ist-ref 'ipaddr
2680: 63 61 70 74 6e 29 29 0a 09 20 20 20 20 20 20 20 captn))..
2690: 28 70 69 64 20 20 20 20 28 61 6c 69 73 74 2d 72 (pid (alist-r
26a0: 65 66 20 27 70 69 64 20 20 20 20 63 61 70 74 6e ef 'pid captn
26b0: 29 29 29 0a 09 20 20 28 75 64 61 74 2d 63 61 70 ))).. (udat-cap
26c0: 74 61 69 6e 2d 61 64 64 72 65 73 73 2d 73 65 74 tain-address-set
26d0: 21 20 75 64 61 74 61 20 69 70 61 64 64 72 29 0a ! udata ipaddr).
26e0: 09 20 20 28 75 64 61 74 2d 63 61 70 74 61 69 6e . (udat-captain
26f0: 2d 68 6f 73 74 2d 73 65 74 21 20 20 20 20 75 64 -host-set! ud
2700: 61 74 61 20 68 6f 73 74 29 0a 09 20 20 28 75 64 ata host).. (ud
2710: 61 74 2d 63 61 70 74 61 69 6e 2d 70 6f 72 74 2d at-captain-port-
2720: 73 65 74 21 20 20 20 20 75 64 61 74 61 20 70 6f set! udata po
2730: 72 74 29 0a 09 20 20 28 75 64 61 74 2d 63 61 70 rt).. (udat-cap
2740: 74 61 69 6e 2d 70 69 64 2d 73 65 74 21 20 20 20 tain-pid-set!
2750: 20 20 75 64 61 74 61 20 70 69 64 29 0a 09 20 20 udata pid)..
2760: 3b 3b 28 69 66 20 28 70 69 6e 67 2d 63 61 70 74 ;;(if (ping-capt
2770: 61 69 6e 20 75 64 61 74 61 29 0a 09 20 20 3b 3b ain udata).. ;;
2780: 20 20 20 20 75 64 61 74 61 0a 09 20 20 3b 3b 20 udata.. ;;
2790: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 (begin.. ;;
27a0: 20 20 20 20 20 20 28 72 65 6d 6f 76 65 2d 63 61 (remove-ca
27b0: 70 74 61 69 6e 2d 70 6b 74 20 75 64 61 74 61 20 ptain-pkt udata
27c0: 63 61 70 74 6e 29 0a 09 20 20 3b 3b 20 20 20 20 captn).. ;;
27d0: 20 20 20 28 73 65 74 75 70 29 29 29 0a 09 20 20 (setup)))..
27e0: 75 64 61 74 61 29 0a 09 28 73 65 74 75 70 2d 61 udata)..(setup-a
27f0: 73 2d 63 61 70 74 61 69 6e 20 75 64 61 74 61 29 s-captain udata)
2800: 29 20 3b 3b 20 74 68 69 73 20 73 61 76 65 73 20 ) ;; this saves
2810: 74 68 65 20 74 68 72 65 61 64 20 74 6f 20 63 61 the thread to ca
2820: 70 74 61 69 6e 2d 74 68 72 65 61 64 20 61 6e 64 ptain-thread and
2830: 20 73 74 61 72 74 73 20 74 68 65 20 74 68 72 65 starts the thre
2840: 61 64 0a 20 20 20 20 29 29 0a 20 20 20 20 0a 28 ad. )). .(
2850: 64 65 66 69 6e 65 20 28 63 6f 6e 6e 65 63 74 20 define (connect
2860: 75 64 61 74 61 20 64 62 66 6e 61 6d 65 29 0a 20 udata dbfname).
2870: 20 75 64 61 74 61 29 0a 0a 29 20 3b 3b 20 45 4e udata)..) ;; EN
2880: 44 20 4f 46 20 55 4c 45 58 0a 0a 0a 3b 3b 3b 20 D OF ULEX...;;;
2890: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
28a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 ========.;;; ;;
28e0: 44 20 45 20 42 20 55 20 47 20 20 20 48 20 45 20 D E B U G H E
28f0: 4c 20 50 20 45 20 52 20 53 0a 3b 3b 3b 20 3b 3b L P E R S.;;; ;;
2900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2940: 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 20 20 20 20 0a ======.;;; .
2950: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 62 67 ;;; (define (dbg
2960: 3e 20 2e 20 61 72 67 73 29 0a 3b 3b 3b 20 20 20 > . args).;;;
2970: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
2980: 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 port (current-er
2990: 72 6f 72 2d 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 ror-port).;;;
29a0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b (lambda ().;;;
29b0: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 (apply pr
29c0: 69 6e 74 20 22 64 62 67 3e 20 22 20 61 72 67 73 int "dbg> " args
29d0: 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 )))).;;; .;;; (d
29e0: 65 66 69 6e 65 20 28 64 65 62 75 67 2d 70 70 20 efine (debug-pp
29f0: 2e 20 61 72 67 73 29 0a 3b 3b 3b 20 20 20 28 69 . args).;;; (i
2a00: 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 f (get-environme
2a10: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 55 4c 45 nt-variable "ULE
2a20: 58 5f 44 45 42 55 47 22 29 0a 3b 3b 3b 20 20 20 X_DEBUG").;;;
2a30: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
2a40: 2d 74 6f 2d 70 6f 72 74 20 28 63 75 72 72 65 6e -to-port (curren
2a50: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 0a 3b 3b t-error-port).;;
2a60: 3b 20 09 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b ; .(lambda ().;;
2a70: 3b 20 09 20 20 28 61 70 70 6c 79 20 70 70 20 61 ; . (apply pp a
2a80: 72 67 73 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b rgs))))).;;; .;;
2a90: 3b 20 28 64 65 66 69 6e 65 20 2a 64 65 66 61 75 ; (define *defau
2aa0: 6c 74 2d 64 65 62 75 67 2d 70 6f 72 74 2a 20 28 lt-debug-port* (
2ab0: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
2ac0: 72 74 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 rt)).;;; .;;; (d
2ad0: 65 66 69 6e 65 20 28 73 64 62 67 3e 20 66 6e 20 efine (sdbg> fn
2ae0: 73 74 61 67 65 2d 6e 61 6d 65 20 73 74 61 67 65 stage-name stage
2af0: 2d 73 74 61 72 74 20 73 74 61 67 65 2d 65 6e 64 -start stage-end
2b00: 20 73 74 61 72 74 2d 74 69 6d 65 20 2e 20 6d 65 start-time . me
2b10: 73 73 61 67 65 29 0a 3b 3b 3b 20 20 20 28 69 66 ssage).;;; (if
2b20: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
2b30: 74 2d 76 61 72 69 61 62 6c 65 20 22 55 4c 45 58 t-variable "ULEX
2b40: 5f 44 45 42 55 47 22 29 0a 3b 3b 3b 20 20 20 20 _DEBUG").;;;
2b50: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
2b60: 74 6f 2d 70 6f 72 74 20 2a 64 65 66 61 75 6c 74 to-port *default
2b70: 2d 64 65 62 75 67 2d 70 6f 72 74 2a 20 0a 3b 3b -debug-port* .;;
2b80: 3b 20 09 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b ; .(lambda ().;;
2b90: 3b 20 09 20 20 28 61 70 70 6c 79 20 70 72 69 6e ; . (apply prin
2ba0: 74 20 22 75 6c 65 78 3a 22 20 66 6e 20 22 20 22 t "ulex:" fn " "
2bb0: 20 73 74 61 67 65 2d 6e 61 6d 65 20 22 20 74 6f stage-name " to
2bc0: 6f 6b 20 22 20 28 2d 20 28 69 66 20 73 74 61 67 ok " (- (if stag
2bd0: 65 2d 65 6e 64 20 73 74 61 67 65 2d 65 6e 64 20 e-end stage-end
2be0: 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 (current-millise
2bf0: 63 6f 6e 64 73 29 29 20 73 74 61 67 65 2d 73 74 conds)) stage-st
2c00: 61 72 74 29 20 22 20 6d 73 2e 20 22 0a 3b 3b 3b art) " ms. ".;;;
2c10: 20 09 09 20 28 69 66 20 73 74 61 72 74 2d 74 69 .. (if start-ti
2c20: 6d 65 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 63 me.;;; .. (c
2c30: 6f 6e 63 20 22 74 6f 74 61 6c 20 74 69 6d 65 20 onc "total time
2c40: 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 " (- (current-mi
2c50: 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 lliseconds) star
2c60: 74 2d 74 69 6d 65 29 0a 3b 3b 3b 20 09 09 09 20 t-time).;;; ...
2c70: 20 20 22 20 6d 73 2e 22 29 0a 3b 3b 3b 20 09 09 " ms.").;;; ..
2c80: 20 20 20 20 20 22 22 29 0a 3b 3b 3b 20 09 09 20 "").;;; ..
2c90: 6d 65 73 73 61 67 65 0a 3b 3b 3b 20 09 09 20 29 message.;;; .. )
2ca0: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
2cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
2cf0: 3b 20 4d 20 41 20 43 20 52 20 4f 20 53 0a 3b 3b ; M A C R O S.;;
2d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d40: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 69 75 70 20 63 61 ======.;; iup ca
2d50: 6c 6c 62 61 63 6b 73 20 61 72 65 20 6e 6f 74 20 llbacks are not
2d60: 64 75 6d 70 69 6e 67 20 74 68 65 20 73 74 61 63 dumping the stac
2d70: 6b 2c 20 74 68 69 73 20 69 73 20 61 20 77 6f 72 k, this is a wor
2d80: 6b 2d 61 72 6f 75 6e 64 0a 3b 3b 0a 0a 3b 3b 20 k-around.;;..;;
2d90: 53 6f 6d 65 20 6f 66 20 74 68 65 73 65 20 72 6f Some of these ro
2da0: 75 74 69 6e 65 73 20 75 73 65 3a 0a 3b 3b 0a 3b utines use:.;;.;
2db0: 3b 20 20 20 20 20 68 74 74 70 3a 2f 2f 77 77 77 ; http://www
2dc0: 2e 63 73 2e 74 6f 72 6f 6e 74 6f 2e 65 64 75 2f .cs.toronto.edu/
2dd0: 7e 67 66 62 2f 73 63 68 65 6d 65 2f 73 69 6d 70 ~gfb/scheme/simp
2de0: 6c 65 2d 6d 61 63 72 6f 73 2e 68 74 6d 6c 0a 3b le-macros.html.;
2df0: 3b 0a 3b 3b 20 53 79 6e 74 61 78 20 66 6f 72 20 ;.;; Syntax for
2e00: 64 65 66 69 6e 69 6e 67 20 6d 61 63 72 6f 73 20 defining macros
2e10: 69 6e 20 61 20 73 69 6d 70 6c 65 20 73 74 79 6c in a simple styl
2e20: 65 20 73 69 6d 69 6c 61 72 20 74 6f 20 66 75 6e e similar to fun
2e30: 63 74 69 6f 6e 20 64 65 66 69 6e 69 74 6f 6e 2c ction definiton,
2e40: 0a 3b 3b 20 20 77 68 65 6e 20 74 68 65 72 65 20 .;; when there
2e50: 69 73 20 61 20 73 69 6e 67 6c 65 20 70 61 74 74 is a single patt
2e60: 65 72 6e 20 66 6f 72 20 74 68 65 20 61 72 67 75 ern for the argu
2e70: 6d 65 6e 74 20 6c 69 73 74 20 61 6e 64 20 74 68 ment list and th
2e80: 65 72 65 20 61 72 65 20 6e 6f 20 6b 65 79 77 6f ere are no keywo
2e90: 72 64 73 2e 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 rds..;;.;; (defi
2ea0: 6e 65 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 61 78 ne-simple-syntax
2eb0: 20 28 6e 61 6d 65 20 61 72 67 20 2e 2e 2e 29 20 (name arg ...)
2ec0: 62 6f 64 79 20 2e 2e 2e 29 0a 3b 3b 0a 3b 3b 20 body ...).;;.;;
2ed0: 0a 3b 3b 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 .;; (define-synt
2ee0: 61 78 20 64 65 66 69 6e 65 2d 73 69 6d 70 6c 65 ax define-simple
2ef0: 2d 73 79 6e 74 61 78 0a 3b 3b 20 20 20 28 73 79 -syntax.;; (sy
2f00: 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 3b 3b ntax-rules ().;;
2f10: 20 20 20 20 20 28 28 5f 20 28 6e 61 6d 65 20 61 ((_ (name a
2f20: 72 67 20 2e 2e 2e 29 20 62 6f 64 79 20 2e 2e 2e rg ...) body ...
2f30: 29 0a 3b 3b 20 20 20 20 20 20 28 64 65 66 69 6e ).;; (defin
2f40: 65 2d 73 79 6e 74 61 78 20 6e 61 6d 65 20 28 73 e-syntax name (s
2f50: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 20 28 yntax-rules () (
2f60: 28 6e 61 6d 65 20 61 72 67 20 2e 2e 2e 29 20 28 (name arg ...) (
2f70: 62 65 67 69 6e 20 62 6f 64 79 20 2e 2e 2e 29 29 begin body ...))
2f80: 29 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 ))))).;; .;; (de
2f90: 66 69 6e 65 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 fine-simple-synt
2fa0: 61 78 20 28 63 61 74 63 68 2d 61 6e 64 2d 64 75 ax (catch-and-du
2fb0: 6d 70 20 70 72 6f 63 20 70 72 6f 63 6e 61 6d 65 mp proc procname
2fc0: 29 0a 3b 3b 20 20 20 28 68 61 6e 64 6c 65 2d 65 ).;; (handle-e
2fd0: 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 20 xceptions.;;
2fe0: 65 78 6e 0a 3b 3b 20 20 20 20 28 62 65 67 69 6e exn.;; (begin
2ff0: 0a 3b 3b 20 20 20 20 20 20 28 70 72 69 6e 74 2d .;; (print-
3000: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
3010: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
3020: 0a 3b 3b 20 20 20 20 20 20 28 77 69 74 68 2d 6f .;; (with-o
3030: 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 63 utput-to-port (c
3040: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
3050: 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 6c 61 t).;; (la
3060: 6d 62 64 61 20 28 29 0a 3b 3b 20 20 20 20 20 20 mbda ().;;
3070: 20 20 20 20 28 70 72 69 6e 74 20 28 28 63 6f 6e (print ((con
3080: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
3090: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
30a0: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 3b 3b essage) exn)).;;
30b0: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
30c0: 20 22 43 61 6c 6c 62 61 63 6b 20 65 72 72 6f 72 "Callback error
30d0: 20 69 6e 20 22 20 70 72 6f 63 6e 61 6d 65 29 0a in " procname).
30e0: 3b 3b 20 20 20 20 20 20 20 20 20 20 28 70 72 69 ;; (pri
30f0: 6e 74 20 22 46 75 6c 6c 20 63 6f 6e 64 69 74 69 nt "Full conditi
3100: 6f 6e 20 69 6e 66 6f 3a 5c 6e 22 20 28 63 6f 6e on info:\n" (con
3110: 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e dition->list exn
3120: 29 29 29 29 29 0a 3b 3b 20 20 20 20 28 70 72 6f ))))).;; (pro
3130: 63 29 29 29 0a 3b 3b 20 0a 3b 3b 20 0a 3b 3b 3d c))).;; .;; .;;=
3140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3180: 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 20 45 20 43 20 =====.;; R E C
3190: 4f 20 52 20 44 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d O R D S.;;======
31a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31e0: 0a 0a 3b 3b 3b 20 3b 3b 20 69 6e 66 6f 72 6d 61 ..;;; ;; informa
31f0: 74 69 6f 6e 20 61 62 6f 75 74 20 6d 65 20 61 73 tion about me as
3200: 20 61 20 73 65 72 76 65 72 0a 3b 3b 3b 20 3b 3b a server.;;; ;;
3210: 0a 3b 3b 3b 20 28 64 65 66 73 74 72 75 63 74 20 .;;; (defstruct
3220: 61 72 65 61 0a 3b 3b 3b 20 20 20 3b 3b 20 61 62 area.;;; ;; ab
3230: 6f 75 74 20 74 68 69 73 20 61 72 65 61 0a 3b 3b out this area.;;
3240: 3b 20 20 20 28 75 73 65 70 6f 72 74 6c 6f 67 67 ; (useportlogg
3250: 65 72 20 23 66 29 0a 3b 3b 3b 20 20 20 28 6c 6f er #f).;;; (lo
3260: 77 70 6f 72 74 20 20 20 20 20 20 20 33 32 37 36 wport 3276
3270: 38 29 0a 3b 3b 3b 20 20 20 28 73 65 72 76 65 72 8).;;; (server
3280: 2d 74 79 70 65 20 20 20 27 61 75 74 6f 29 20 20 -type 'auto)
3290: 3b 3b 20 61 75 74 6f 3d 63 72 65 61 74 65 20 75 ;; auto=create u
32a0: 70 20 74 6f 20 66 69 76 65 20 73 65 72 76 65 72 p to five server
32b0: 73 2f 70 6b 74 73 2c 20 6d 61 69 6e 3d 63 72 65 s/pkts, main=cre
32c0: 61 74 65 20 70 6b 74 73 2c 20 70 61 73 73 69 76 ate pkts, passiv
32d0: 65 3d 6e 6f 20 70 6b 74 20 28 75 6e 6c 65 73 73 e=no pkt (unless
32e0: 20 74 68 65 72 65 20 61 72 65 20 6e 6f 20 70 6b there are no pk
32f0: 74 73 20 61 74 20 61 6c 6c 29 0a 3b 3b 3b 20 20 ts at all).;;;
3300: 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 (conn
3310: 23 66 29 0a 3b 3b 3b 20 20 20 28 70 6f 72 74 20 #f).;;; (port
3320: 20 20 20 20 20 20 20 20 20 23 66 29 0a 3b 3b 3b #f).;;;
3330: 20 20 20 28 6d 79 61 64 64 72 20 20 20 20 20 20 (myaddr
3340: 20 20 28 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 (get-my-best-a
3350: 64 64 72 65 73 73 29 29 0a 3b 3b 3b 20 20 20 70 ddress)).;;; p
3360: 6b 74 69 64 20 20 20 20 20 20 20 20 20 20 3b 3b ktid ;;
3370: 20 67 65 74 20 70 6b 74 20 66 72 6f 6d 20 68 6f get pkt from ho
3380: 73 74 73 20 74 61 62 6c 65 20 69 66 20 6e 65 65 sts table if nee
3390: 64 65 64 0a 3b 3b 3b 20 20 20 70 6b 74 66 69 6c ded.;;; pktfil
33a0: 65 0a 3b 3b 3b 20 20 20 70 6b 74 73 64 69 72 0a e.;;; pktsdir.
33b0: 3b 3b 3b 20 20 20 64 62 64 69 72 0a 3b 3b 3b 20 ;;; dbdir.;;;
33c0: 20 20 28 64 62 68 61 6e 64 6c 65 73 20 20 20 20 (dbhandles
33d0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
33e0: 65 29 29 20 3b 3b 20 66 6e 61 6d 65 20 3d 3e 20 e)) ;; fname =>
33f0: 6c 69 73 74 2d 6f 66 2d 64 62 68 2c 20 4e 4f 54 list-of-dbh, NOT
3400: 45 3a 20 53 68 6f 75 6c 64 20 72 65 61 6c 6c 79 E: Should really
3410: 20 6e 65 76 65 72 20 6e 65 65 64 20 6d 6f 72 65 never need more
3420: 20 74 68 61 6e 20 6f 6e 65 3f 0a 3b 3b 3b 20 20 than one?.;;;
3430: 20 28 6d 75 74 65 78 20 20 20 20 20 20 20 20 20 (mutex
3440: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 3b 3b (make-mutex)).;;
3450: 3b 20 20 20 28 72 74 61 62 6c 65 20 20 20 20 20 ; (rtable
3460: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
3470: 62 6c 65 29 29 20 3b 3b 20 72 65 67 69 73 74 72 ble)) ;; registr
3480: 61 74 69 6f 6e 20 74 61 62 6c 65 20 6f 66 20 61 ation table of a
3490: 76 61 69 6c 61 62 6c 65 20 61 63 74 69 6f 6e 73 vailable actions
34a0: 0a 3b 3b 3b 20 20 20 28 64 62 73 20 20 20 20 20 .;;; (dbs
34b0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
34c0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 66 69 6c 65 -table)) ;; file
34d0: 6e 61 6d 65 20 3d 3e 20 72 61 6e 64 6f 6d 20 6e name => random n
34e0: 75 6d 62 65 72 2c 20 75 73 65 64 20 66 6f 72 20 umber, used for
34f0: 63 68 6f 6f 73 69 6e 67 20 77 68 61 74 20 64 62 choosing what db
3500: 73 20 49 20 73 65 72 76 65 0a 3b 3b 3b 20 20 20 s I serve.;;;
3510: 3b 3b 20 61 62 6f 75 74 20 6f 74 68 65 72 20 73 ;; about other s
3520: 65 72 76 65 72 73 0a 3b 3b 3b 20 20 20 28 68 6f ervers.;;; (ho
3530: 73 74 73 20 20 20 20 20 20 20 20 20 28 6d 61 6b sts (mak
3540: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
3550: 3b 20 6b 65 79 20 3d 3e 20 68 6f 73 74 64 61 74 ; key => hostdat
3560: 0a 3b 3b 3b 20 20 20 28 68 6f 73 74 73 74 61 74 .;;; (hoststat
3570: 73 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 s (make-hash
3580: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 6b 65 79 20 -table)) ;; key
3590: 3d 3e 20 61 6c 69 73 74 20 6f 66 20 66 6e 61 6d => alist of fnam
35a0: 65 20 3d 3e 20 28 20 71 63 6f 75 6e 74 20 2e 20 e => ( qcount .
35b0: 71 74 69 6d 65 20 29 0a 3b 3b 3b 20 20 20 28 72 qtime ).;;; (r
35c0: 65 71 73 20 20 20 20 20 20 20 20 20 20 28 6d 61 eqs (ma
35d0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
35e0: 3b 3b 20 75 72 69 20 3d 3e 20 71 75 65 75 65 0a ;; uri => queue.
35f0: 3b 3b 3b 20 20 20 3b 3b 20 77 6f 72 6b 20 71 75 ;;; ;; work qu
3600: 65 75 65 73 0a 3b 3b 3b 20 20 20 28 77 71 75 65 eues.;;; (wque
3610: 75 65 73 20 20 20 20 20 20 20 28 6d 61 6b 65 2d ues (make-
3620: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
3630: 66 6e 61 6d 65 20 3d 3e 20 71 64 61 74 0a 3b 3b fname => qdat.;;
3640: 3b 20 20 20 28 73 74 61 74 73 20 20 20 20 20 20 ; (stats
3650: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
3660: 62 6c 65 29 29 20 3b 3b 20 66 6e 61 6d 65 20 3d ble)) ;; fname =
3670: 3e 20 74 6f 74 61 6c 71 75 65 72 69 65 73 0a 3b > totalqueries.;
3680: 3b 3b 20 20 20 28 6c 61 73 74 2d 73 72 76 75 70 ;; (last-srvup
3690: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (current-sec
36a0: 6f 6e 64 73 29 29 20 3b 3b 20 6c 61 73 74 20 74 onds)) ;; last t
36b0: 69 6d 65 20 77 65 20 75 70 64 61 74 65 64 20 74 ime we updated t
36c0: 68 65 20 6b 6e 6f 77 6e 20 73 65 72 76 65 72 73 he known servers
36d0: 0a 3b 3b 3b 20 20 20 28 63 6f 6f 6b 69 65 32 6d .;;; (cookie2m
36e0: 62 6f 78 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 box (make-hash
36f0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 6d 61 70 20 -table)) ;; map
3700: 63 6f 6f 6b 69 65 20 66 6f 72 20 6f 75 74 73 74 cookie for outst
3710: 61 6e 64 69 6e 67 20 72 65 71 75 65 73 74 20 74 anding request t
3720: 6f 20 6d 61 69 6c 62 6f 78 20 6f 66 20 61 77 61 o mailbox of awa
3730: 69 74 69 6e 67 20 63 61 6c 6c 0a 3b 3b 3b 20 20 iting call.;;;
3740: 20 28 72 65 61 64 79 20 23 66 29 0a 3b 3b 3b 20 (ready #f).;;;
3750: 20 20 28 68 65 61 6c 74 68 20 20 20 20 20 20 20 (health
3760: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
3770: 65 29 29 20 3b 3b 20 69 70 61 64 64 72 3a 70 6f e)) ;; ipaddr:po
3780: 72 74 20 3d 3e 20 6e 75 6d 20 66 61 69 6c 65 64 rt => num failed
3790: 20 70 69 6e 67 73 20 73 69 6e 63 65 20 6c 61 73 pings since las
37a0: 74 20 67 6f 6f 64 20 70 69 6e 67 0a 3b 3b 3b 20 t good ping.;;;
37b0: 20 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 ).;;; .;;; ;;
37c0: 68 6f 73 74 20 73 74 61 74 73 0a 3b 3b 3b 20 3b host stats.;;; ;
37d0: 3b 0a 3b 3b 3b 20 28 64 65 66 73 74 72 75 63 74 ;.;;; (defstruct
37e0: 20 68 6f 73 74 64 61 74 0a 3b 3b 3b 20 20 20 28 hostdat.;;; (
37f0: 70 6b 74 20 20 20 20 20 20 23 66 29 0a 3b 3b 3b pkt #f).;;;
3800: 20 20 20 28 64 62 6c 6f 61 64 20 20 20 28 6d 61 (dbload (ma
3810: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
3820: 20 3b 3b 20 22 64 62 66 69 6c 65 2e 64 62 22 20 ;; "dbfile.db"
3830: 3d 3e 20 71 75 65 72 69 65 73 2f 6d 69 6e 0a 3b => queries/min.;
3840: 3b 3b 20 20 20 28 68 6f 73 74 6c 6f 61 64 20 23 ;; (hostload #
3850: 66 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 f)
3860: 20 20 20 3b 3b 20 6e 6f 72 6d 61 6c 69 7a 65 64 ;; normalized
3870: 20 6c 6f 61 64 20 28 20 35 6d 69 6e 20 6c 6f 61 load ( 5min loa
3880: 64 20 2f 20 6e 75 6d 63 70 75 73 20 29 0a 3b 3b d / numcpus ).;;
3890: 3b 20 20 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b ; ).;;; .;;; ;
38a0: 3b 20 64 62 64 61 74 0a 3b 3b 3b 20 3b 3b 0a 3b ; dbdat.;;; ;;.;
38b0: 3b 3b 20 28 64 65 66 73 74 72 75 63 74 20 64 62 ;; (defstruct db
38c0: 64 61 74 0a 3b 3b 3b 20 20 20 28 64 62 68 20 20 dat.;;; (dbh
38d0: 20 20 23 66 29 0a 3b 3b 3b 20 20 20 28 66 6e 61 #f).;;; (fna
38e0: 6d 65 20 20 23 66 29 0a 3b 3b 3b 20 20 20 28 77 me #f).;;; (w
38f0: 72 69 74 65 2d 61 63 63 65 73 73 20 23 66 29 0a rite-access #f).
3900: 3b 3b 3b 20 20 20 28 73 74 68 73 20 20 20 28 6d ;;; (sths (m
3910: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
3920: 20 20 3b 3b 20 68 61 73 68 20 6d 61 70 70 69 6e ;; hash mappin
3930: 67 20 71 75 65 72 79 20 73 74 72 69 6e 67 73 20 g query strings
3940: 74 6f 20 68 61 6e 64 6c 65 73 0a 3b 3b 3b 20 20 to handles.;;;
3950: 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 71 ).;;; .;;; ;; q
3960: 64 61 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 dat.;;; ;;.;;; (
3970: 64 65 66 73 74 72 75 63 74 20 71 64 61 74 0a 3b defstruct qdat.;
3980: 3b 3b 20 20 20 28 77 72 69 74 65 71 20 20 28 6d ;; (writeq (m
3990: 61 6b 65 2d 71 75 65 75 65 29 29 0a 3b 3b 3b 20 ake-queue)).;;;
39a0: 20 20 28 72 65 61 64 71 20 20 20 28 6d 61 6b 65 (readq (make
39b0: 2d 71 75 65 75 65 29 29 0a 3b 3b 3b 20 20 20 28 -queue)).;;; (
39c0: 72 77 71 20 20 20 20 20 28 6d 61 6b 65 2d 71 75 rwq (make-qu
39d0: 65 75 65 29 29 0a 3b 3b 3b 20 20 20 28 6c 6f 67 eue)).;;; (log
39e0: 71 20 20 20 20 28 6d 61 6b 65 2d 71 75 65 75 65 q (make-queue
39f0: 29 29 20 3b 3b 20 64 6f 20 77 65 20 6e 65 65 64 )) ;; do we need
3a00: 20 61 20 71 75 65 75 65 20 66 6f 72 20 6c 6f 67 a queue for log
3a10: 67 69 6e 67 3f 20 79 65 73 2c 20 69 66 20 77 65 ging? yes, if we
3a20: 20 75 73 65 20 73 71 6c 69 74 65 33 20 64 62 20 use sqlite3 db
3a30: 66 6f 72 20 6c 6f 67 67 69 6e 67 0a 3b 3b 3b 20 for logging.;;;
3a40: 20 20 28 6f 73 73 68 6f 72 74 20 28 6d 61 6b 65 (osshort (make
3a50: 2d 71 75 65 75 65 29 29 0a 3b 3b 3b 20 20 20 28 -queue)).;;; (
3a60: 6f 73 6c 6f 6e 67 20 20 28 6d 61 6b 65 2d 71 75 oslong (make-qu
3a70: 65 75 65 29 29 0a 3b 3b 3b 20 20 20 28 6d 69 73 eue)).;;; (mis
3a80: 63 20 20 20 20 28 6d 61 6b 65 2d 71 75 65 75 65 c (make-queue
3a90: 29 29 20 3b 3b 20 75 73 65 64 20 66 6f 72 20 74 )) ;; used for t
3aa0: 68 69 6e 67 73 20 6c 69 6b 65 20 70 69 6e 67 2d hings like ping-
3ab0: 66 75 6c 6c 0a 3b 3b 3b 20 20 20 29 0a 3b 3b 3b full.;;; ).;;;
3ac0: 20 0a 3b 3b 3b 20 3b 3b 20 63 61 6c 6c 64 61 74 .;;; ;; calldat
3ad0: 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 .;;; ;;.;;; (def
3ae0: 73 74 72 75 63 74 20 63 61 6c 6c 64 61 74 0a 3b struct calldat.;
3af0: 3b 3b 20 20 20 28 63 74 79 70 65 20 27 64 62 77 ;; (ctype 'dbw
3b00: 72 69 74 65 29 0a 3b 3b 3b 20 20 20 28 6f 62 6a rite).;;; (obj
3b10: 20 20 20 23 66 29 20 20 20 20 20 20 20 20 20 20 #f)
3b20: 20 20 20 20 3b 3b 20 74 68 69 73 20 77 6f 75 6c ;; this woul
3b30: 64 20 6e 6f 72 6d 61 6c 6c 79 20 62 65 20 61 6e d normally be an
3b40: 20 53 51 4c 20 73 74 61 74 65 6d 65 6e 74 20 65 SQL statement e
3b50: 2e 67 2e 20 53 45 4c 45 43 54 2c 20 49 4e 53 45 .g. SELECT, INSE
3b60: 52 54 20 65 74 63 2e 0a 3b 3b 3b 20 20 20 28 72 RT etc..;;; (r
3b70: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 time (current-mi
3b80: 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b lliseconds))).;;
3b90: 3b 20 0a 3b 3b 3b 20 3b 3b 20 6d 61 6b 65 20 69 ; .;;; ;; make i
3ba0: 74 20 61 20 67 6c 6f 62 61 6c 3f 20 57 65 6c 6c t a global? Well
3bb0: 2c 20 69 74 20 69 73 20 6c 6f 63 61 6c 20 74 6f , it is local to
3bc0: 20 61 72 65 61 20 6d 6f 64 75 6c 65 0a 3b 3b 3b area module.;;;
3bd0: 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 2a 70 .;;; (define *p
3be0: 6b 74 73 70 65 63 2a 0a 3b 3b 3b 20 20 20 60 28 ktspec*.;;; `(
3bf0: 28 73 65 72 76 65 72 20 28 68 6f 73 74 6e 61 6d (server (hostnam
3c00: 65 20 2e 20 68 29 0a 3b 3b 3b 20 09 20 20 20 20 e . h).;;; .
3c10: 28 70 6f 72 74 20 20 20 20 20 2e 20 70 29 0a 3b (port . p).;
3c20: 3b 3b 20 09 20 20 20 20 28 70 69 64 20 20 20 20 ;; . (pid
3c30: 20 20 2e 20 69 29 0a 3b 3b 3b 20 09 20 20 20 20 . i).;;; .
3c40: 28 69 70 61 64 64 72 20 20 20 2e 20 61 29 0a 3b (ipaddr . a).;
3c50: 3b 3b 20 09 20 20 20 20 29 0a 3b 3b 3b 20 20 20 ;; . ).;;;
3c60: 20 20 28 64 61 74 61 20 20 20 28 68 6f 73 74 6e (data (hostn
3c70: 61 6d 65 20 2e 20 68 29 20 20 3b 3b 20 73 65 6e ame . h) ;; sen
3c80: 64 65 72 20 68 6f 73 74 6e 61 6d 65 0a 3b 3b 3b der hostname.;;;
3c90: 20 09 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 . (port
3ca0: 2e 20 70 29 20 20 3b 3b 20 73 65 6e 64 65 72 20 . p) ;; sender
3cb0: 70 6f 72 74 0a 3b 3b 3b 20 09 20 20 20 20 28 69 port.;;; . (i
3cc0: 70 61 64 64 72 20 20 20 2e 20 61 29 20 20 3b 3b paddr . a) ;;
3cd0: 20 73 65 6e 64 65 72 20 69 70 0a 3b 3b 3b 20 09 sender ip.;;; .
3ce0: 20 20 20 20 28 68 6f 73 74 6b 65 79 20 20 2e 20 (hostkey .
3cf0: 6b 29 20 20 3b 3b 20 73 65 6e 64 69 6e 67 20 68 k) ;; sending h
3d00: 6f 73 74 20 6b 65 79 20 2d 20 73 74 6f 72 65 20 ost key - store
3d10: 69 6e 66 6f 20 61 74 20 73 65 72 76 65 72 20 75 info at server u
3d20: 6e 64 65 72 20 74 68 69 73 20 6b 65 79 0a 3b 3b nder this key.;;
3d30: 3b 20 09 20 20 20 20 28 73 65 72 76 6b 65 79 20 ; . (servkey
3d40: 20 2e 20 73 29 20 20 3b 3b 20 73 65 72 76 65 72 . s) ;; server
3d50: 20 6b 65 79 20 2d 20 74 68 69 73 20 6e 65 65 64 key - this need
3d60: 73 20 74 6f 20 6d 61 74 63 68 20 61 74 20 73 65 s to match at se
3d70: 72 76 65 72 20 65 6e 64 20 6f 72 20 72 65 6a 65 rver end or reje
3d80: 63 74 20 74 68 65 20 6d 73 67 0a 3b 3b 3b 20 09 ct the msg.;;; .
3d90: 20 20 20 20 28 66 6f 72 6d 61 74 20 20 20 2e 20 (format .
3da0: 66 29 20 20 3b 3b 20 73 62 3d 73 65 72 69 61 6c f) ;; sb=serial
3db0: 69 7a 65 64 2d 62 61 73 65 36 34 2c 20 74 3d 74 ized-base64, t=t
3dc0: 65 78 74 2c 20 73 78 3d 73 65 78 70 72 2c 20 6a ext, sx=sexpr, j
3dd0: 3d 6a 73 6f 6e 0a 3b 3b 3b 20 09 20 20 20 20 28 =json.;;; . (
3de0: 64 61 74 61 20 20 20 20 20 2e 20 64 29 20 20 3b data . d) ;
3df0: 3b 20 62 61 73 65 36 34 20 65 6e 63 6f 64 65 64 ; base64 encoded
3e00: 20 73 6c 6c 6e 20 64 61 74 61 0a 3b 3b 3b 20 09 slln data.;;; .
3e10: 20 20 20 20 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b ))).;;; .;;;
3e20: 20 3b 3b 20 77 6f 72 6b 20 69 74 65 6d 0a 3b 3b ;; work item.;;
3e30: 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 73 74 72 ; ;;.;;; (defstr
3e40: 75 63 74 20 77 69 74 65 6d 0a 3b 3b 3b 20 20 20 uct witem.;;;
3e50: 28 72 68 6f 73 74 20 23 66 29 20 20 20 3b 3b 20 (rhost #f) ;;
3e60: 72 65 74 75 72 6e 20 68 6f 73 74 0a 3b 3b 3b 20 return host.;;;
3e70: 20 20 28 72 69 70 61 64 64 72 20 23 66 29 20 3b (ripaddr #f) ;
3e80: 3b 20 72 65 74 75 72 6e 20 69 70 61 64 64 72 0a ; return ipaddr.
3e90: 3b 3b 3b 20 20 20 28 72 70 6f 72 74 20 23 66 29 ;;; (rport #f)
3ea0: 20 20 20 3b 3b 20 72 65 74 75 72 6e 20 70 6f 72 ;; return por
3eb0: 74 0a 3b 3b 3b 20 20 20 28 73 65 72 76 6b 65 79 t.;;; (servkey
3ec0: 20 23 66 29 20 3b 3b 20 74 68 65 20 70 61 63 6b #f) ;; the pack
3ed0: 65 74 20 72 65 70 72 65 73 65 6e 74 69 6e 67 20 et representing
3ee0: 74 68 65 20 63 6c 69 65 6e 74 20 6f 66 20 74 68 the client of th
3ef0: 69 73 20 77 6f 72 6b 69 74 65 6d 2c 20 75 73 65 is workitem, use
3f00: 64 20 62 79 20 66 69 6e 61 6c 20 73 65 6e 64 2d d by final send-
3f10: 6d 65 73 73 61 67 65 0a 3b 3b 3b 20 20 20 28 72 message.;;; (r
3f20: 64 61 74 20 20 23 66 29 20 20 20 3b 3b 20 74 68 dat #f) ;; th
3f30: 65 20 72 65 71 75 65 73 74 20 2d 20 75 73 75 61 e request - usua
3f40: 6c 6c 79 20 61 6e 20 73 71 6c 20 71 75 65 72 79 lly an sql query
3f50: 2c 20 74 79 70 65 20 69 73 20 72 64 61 74 0a 3b , type is rdat.;
3f60: 3b 3b 20 20 20 28 61 63 74 69 6f 6e 20 23 66 29 ;; (action #f)
3f70: 20 20 3b 3b 20 74 68 65 20 61 63 74 69 6f 6e 3a ;; the action:
3f80: 20 69 6d 6d 65 64 69 61 74 65 2c 20 64 62 77 72 immediate, dbwr
3f90: 69 74 65 2c 20 64 62 72 65 61 64 2c 6f 73 6c 6f ite, dbread,oslo
3fa0: 6e 67 2c 20 6f 73 73 68 6f 72 74 0a 3b 3b 3b 20 ng, osshort.;;;
3fb0: 20 20 28 63 6f 6f 6b 69 65 20 23 66 29 20 20 3b (cookie #f) ;
3fc0: 3b 20 63 6f 6f 6b 69 65 20 69 64 20 66 6f 72 20 ; cookie id for
3fd0: 72 65 73 70 6f 6e 73 65 0a 3b 3b 3b 20 20 20 28 response.;;; (
3fe0: 64 61 74 61 20 20 20 23 66 29 20 20 3b 3b 20 74 data #f) ;; t
3ff0: 68 65 20 64 61 74 61 20 70 61 79 6c 6f 61 64 2c he data payload,
4000: 20 69 2e 65 2e 20 70 61 72 61 6d 65 74 65 72 73 i.e. parameters
4010: 0a 3b 3b 3b 20 20 20 28 72 65 73 75 6c 74 20 23 .;;; (result #
4020: 66 29 20 20 3b 3b 20 74 68 65 20 72 65 73 75 6c f) ;; the resul
4030: 74 20 66 72 6f 6d 20 70 72 6f 63 65 73 73 69 6e t from processin
4040: 67 20 74 68 65 20 64 61 74 61 0a 3b 3b 3b 20 20 g the data.;;;
4050: 20 28 63 61 6c 6c 65 72 20 23 66 29 29 20 3b 3b (caller #f)) ;;
4060: 20 74 68 65 20 63 61 6c 6c 69 6e 67 20 70 65 65 the calling pee
4070: 72 20 61 63 63 6f 72 64 69 6e 67 20 74 6f 20 72 r according to r
4080: 70 63 20 69 74 73 65 6c 66 0a 3b 3b 3b 20 0a 3b pc itself.;;; .;
4090: 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 72 69 6d ;; (define (trim
40a0: 2d 70 6b 74 69 64 20 70 6b 74 69 64 29 0a 3b 3b -pktid pktid).;;
40b0: 3b 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f ; (if (string?
40c0: 20 70 6b 74 69 64 29 0a 3b 3b 3b 20 20 20 20 20 pktid).;;;
40d0: 20 20 28 73 75 62 73 74 72 69 6e 67 20 70 6b 74 (substring pkt
40e0: 69 64 20 30 20 34 29 0a 3b 3b 3b 20 20 20 20 20 id 0 4).;;;
40f0: 20 20 22 6e 6f 70 6b 74 22 29 29 0a 3b 3b 3b 20 "nopkt")).;;;
4100: 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 61 6e .;;; (define (an
4110: 79 2d 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 0a 3b y->number num).;
4120: 3b 3b 20 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 20 ;; (cond.;;;
4130: 20 20 28 28 6e 75 6d 62 65 72 3f 20 6e 75 6d 29 ((number? num)
4140: 20 6e 75 6d 29 0a 3b 3b 3b 20 20 20 20 28 28 73 num).;;; ((s
4150: 74 72 69 6e 67 3f 20 6e 75 6d 29 20 28 73 74 72 tring? num) (str
4160: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 ing->number num)
4170: 29 0a 3b 3b 3b 20 20 20 20 28 65 6c 73 65 20 6e ).;;; (else n
4180: 75 6d 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 um))).;;; .;;; (
4190: 75 73 65 20 74 72 61 63 65 29 0a 3b 3b 3b 20 28 use trace).;;; (
41a0: 74 72 61 63 65 2d 63 61 6c 6c 2d 73 69 74 65 73 trace-call-sites
41b0: 20 23 74 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b #t).;;; .;;; ;;
41c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
41d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
41e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
41f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4200: 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 44 20 ======.;;; ;; D
4210: 41 20 54 20 41 20 42 20 41 20 53 20 45 20 20 20 A T A B A S E
4220: 48 20 41 20 4e 20 44 20 4c 20 49 20 4e 20 47 20 H A N D L I N G
4230: 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;; ;;=========
4240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
4280: 3b 20 0a 3b 3b 3b 20 3b 3b 20 6c 6f 6f 6b 20 69 ; .;;; ;; look i
4290: 6e 20 64 62 68 61 6e 64 6c 65 73 20 66 6f 72 20 n dbhandles for
42a0: 61 20 64 62 2c 20 72 65 74 75 72 6e 20 69 74 2c a db, return it,
42b0: 20 65 6c 73 65 20 72 65 74 75 72 6e 20 23 66 0a else return #f.
42c0: 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 ;;; ;;.;;; (defi
42d0: 6e 65 20 28 67 65 74 2d 64 62 68 20 61 63 66 67 ne (get-dbh acfg
42e0: 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 28 6c fname).;;; (l
42f0: 65 74 20 28 28 64 62 68 2d 6c 73 74 20 28 68 61 et ((dbh-lst (ha
4300: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4310: 61 75 6c 74 20 28 61 72 65 61 2d 64 62 68 61 6e ault (area-dbhan
4320: 64 6c 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 dles acfg) fname
4330: 20 27 28 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 '()))).;;;
4340: 28 69 66 20 28 6e 75 6c 6c 3f 20 64 62 68 2d 6c (if (null? dbh-l
4350: 73 74 29 0a 3b 3b 3b 20 09 28 62 65 67 69 6e 0a st).;;; .(begin.
4360: 3b 3b 3b 20 09 20 20 3b 3b 20 28 70 72 69 6e 74 ;;; . ;; (print
4370: 20 22 6f 70 65 6e 69 6e 67 20 64 62 20 66 6f 72 "opening db for
4380: 20 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 20 " fname).;;; .
4390: 20 28 6f 70 65 6e 2d 64 62 20 61 63 66 67 20 66 (open-db acfg f
43a0: 6e 61 6d 65 29 29 20 3b 3b 20 4e 6f 74 65 20 74 name)) ;; Note t
43b0: 68 61 74 20 74 68 65 20 68 61 6e 64 6c 65 73 20 hat the handles
43c0: 67 65 74 20 70 75 74 20 62 61 63 6b 20 69 6e 20 get put back in
43d0: 74 68 65 20 71 75 65 75 65 20 69 6e 20 74 68 65 the queue in the
43e0: 20 73 61 76 65 2d 64 62 68 20 63 61 6c 6c 73 0a save-dbh calls.
43f0: 3b 3b 3b 20 09 28 6c 65 74 20 28 28 72 65 6d 2d ;;; .(let ((rem-
4400: 6c 73 74 20 28 63 64 72 20 64 62 68 2d 6c 73 74 lst (cdr dbh-lst
4410: 29 29 29 0a 3b 3b 3b 20 09 20 20 3b 3b 20 28 70 ))).;;; . ;; (p
4420: 72 69 6e 74 20 22 72 65 2d 75 73 69 6e 67 20 73 rint "re-using s
4430: 61 76 65 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 aved connection
4440: 66 6f 72 20 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b for " fname).;;;
4450: 20 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
4460: 73 65 74 21 20 28 61 72 65 61 2d 64 62 68 61 6e set! (area-dbhan
4470: 64 6c 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 dles acfg) fname
4480: 20 72 65 6d 2d 6c 73 74 29 0a 3b 3b 3b 20 09 20 rem-lst).;;; .
4490: 20 28 63 61 72 20 64 62 68 2d 6c 73 74 29 29 29 (car dbh-lst)))
44a0: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 )).;;; .;;; (def
44b0: 69 6e 65 20 28 73 61 76 65 2d 64 62 68 20 61 63 ine (save-dbh ac
44c0: 66 67 20 66 6e 61 6d 65 20 64 62 64 61 74 29 0a fg fname dbdat).
44d0: 3b 3b 3b 20 20 20 20 20 3b 3b 20 28 70 72 69 6e ;;; ;; (prin
44e0: 74 20 22 73 61 76 69 6e 67 20 64 62 68 20 66 6f t "saving dbh fo
44f0: 72 20 22 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 r " fname).;;;
4500: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
4510: 65 74 21 20 28 61 72 65 61 2d 64 62 68 61 6e 64 et! (area-dbhand
4520: 6c 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 20 les acfg) fname
4530: 28 63 6f 6e 73 20 64 62 64 61 74 20 28 68 61 73 (cons dbdat (has
4540: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4550: 75 6c 74 20 28 61 72 65 61 2d 64 62 68 61 6e 64 ult (area-dbhand
4560: 6c 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 20 les acfg) fname
4570: 27 28 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b '())))).;;; .;;;
4580: 20 3b 3b 20 6f 70 65 6e 20 74 68 65 20 64 61 74 ;; open the dat
4590: 61 62 61 73 65 2c 20 69 66 20 6e 65 76 65 72 20 abase, if never
45a0: 62 65 66 6f 72 65 20 6f 70 65 6e 65 64 20 69 6e before opened in
45b0: 69 74 20 69 74 2e 20 70 75 74 20 74 68 65 20 68 it it. put the h
45c0: 61 6e 64 6c 65 20 69 6e 20 74 68 65 0a 3b 3b 3b andle in the.;;;
45d0: 20 3b 3b 20 6f 70 65 6e 20 64 62 27 73 20 68 61 ;; open db's ha
45e0: 73 68 20 74 61 62 6c 65 0a 3b 3b 3b 20 3b 3b 20 sh table.;;; ;;
45f0: 72 65 74 75 72 6e 73 3a 20 74 68 65 20 64 62 64 returns: the dbd
4600: 61 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 at.;;; ;;.;;; (d
4610: 65 66 69 6e 65 20 28 6f 70 65 6e 2d 64 62 20 61 efine (open-db a
4620: 63 66 67 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 20 cfg fname).;;;
4630: 20 28 6c 65 74 2a 20 28 28 66 75 6c 6c 6e 61 6d (let* ((fullnam
4640: 65 20 20 20 20 20 28 63 6f 6e 63 20 28 61 72 65 e (conc (are
4650: 61 2d 64 62 64 69 72 20 61 63 66 67 29 20 22 2f a-dbdir acfg) "/
4660: 22 20 66 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 " fname)).;;; .
4670: 28 65 78 69 73 74 73 20 20 20 20 20 20 20 28 66 (exists (f
4680: 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c ile-exists? full
4690: 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 28 77 72 name)).;;; . (wr
46a0: 69 74 65 2d 61 63 63 65 73 73 20 28 69 66 20 65 ite-access (if e
46b0: 78 69 73 74 73 0a 3b 3b 3b 20 09 09 09 20 20 20 xists.;;; ...
46c0: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
46d0: 73 73 3f 20 66 75 6c 6c 6e 61 6d 65 29 0a 3b 3b ss? fullname).;;
46e0: 3b 20 09 09 09 20 20 20 28 66 69 6c 65 2d 77 72 ; ... (file-wr
46f0: 69 74 65 2d 61 63 63 65 73 73 3f 20 28 61 72 65 ite-access? (are
4700: 61 2d 64 62 64 69 72 20 61 63 66 67 29 29 29 29 a-dbdir acfg))))
4710: 0a 3b 3b 3b 20 09 20 28 64 62 20 20 20 20 20 20 .;;; . (db
4720: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 6f 70 (sqlite3:op
4730: 65 6e 2d 64 61 74 61 62 61 73 65 20 66 75 6c 6c en-database full
4740: 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 28 68 61 name)).;;; . (ha
4750: 6e 64 6c 65 72 20 20 20 20 20 20 28 73 71 6c 69 ndler (sqli
4760: 74 65 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 69 te3:make-busy-ti
4770: 6d 65 6f 75 74 20 31 33 36 30 30 30 29 29 0a 3b meout 136000)).;
4780: 3b 3b 20 09 20 29 0a 3b 3b 3b 20 20 20 20 20 28 ;; . ).;;; (
4790: 73 71 6c 69 74 65 33 3a 73 65 74 2d 62 75 73 79 sqlite3:set-busy
47a0: 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 68 61 6e -handler! db han
47b0: 64 6c 65 72 29 0a 3b 3b 3b 20 20 20 20 20 28 73 dler).;;; (s
47c0: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
47d0: 62 20 22 50 52 41 47 4d 41 20 73 79 6e 63 68 72 b "PRAGMA synchr
47e0: 6f 6e 6f 75 73 20 3d 20 30 3b 22 29 0a 3b 3b 3b onous = 0;").;;;
47f0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 65 78 (if (not ex
4800: 69 73 74 73 29 20 3b 3b 20 6e 65 65 64 20 74 6f ists) ;; need to
4810: 20 69 6e 69 74 20 74 68 65 20 64 62 0a 3b 3b 3b init the db.;;;
4820: 20 09 28 69 66 20 77 72 69 74 65 2d 61 63 63 65 .(if write-acce
4830: 73 73 0a 3b 3b 3b 20 09 20 20 20 20 28 6c 65 74 ss.;;; . (let
4840: 20 28 28 69 73 71 6c 20 28 67 65 74 2d 72 73 71 ((isql (get-rsq
4850: 6c 20 61 63 66 67 20 27 64 62 69 6e 69 74 73 71 l acfg 'dbinitsq
4860: 6c 29 29 29 20 3b 3b 20 67 65 74 20 74 68 65 20 l))) ;; get the
4870: 69 6e 69 74 20 73 71 6c 20 73 74 61 74 65 6d 65 init sql stateme
4880: 6e 74 73 0a 3b 3b 3b 20 09 20 20 20 20 20 20 3b nts.;;; . ;
4890: 3b 20 28 73 71 6c 69 74 65 33 3a 77 69 74 68 2d ; (sqlite3:with-
48a0: 74 72 61 6e 73 61 63 74 69 6f 6e 0a 3b 3b 3b 20 transaction.;;;
48b0: 09 20 20 20 20 20 20 3b 3b 20 20 64 62 0a 3b 3b . ;; db.;;
48c0: 3b 20 09 20 20 20 20 20 20 3b 3b 20 20 28 6c 61 ; . ;; (la
48d0: 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 09 09 20 28 mbda ().;;; .. (
48e0: 69 66 20 69 73 71 6c 0a 3b 3b 3b 20 09 09 20 20 if isql.;;; ..
48f0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b (for-each.;;;
4900: 20 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
4910: 20 28 73 71 6c 29 0a 3b 3b 3b 20 09 09 09 28 73 (sql).;;; ...(s
4920: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
4930: 62 20 73 71 6c 29 29 0a 3b 3b 3b 20 09 09 20 20 b sql)).;;; ..
4940: 20 20 20 20 69 73 71 6c 29 29 29 0a 3b 3b 3b 20 isql))).;;;
4950: 09 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 . (print "ERR
4960: 4f 52 3a 20 6e 6f 20 77 72 69 74 65 20 61 63 63 OR: no write acc
4970: 65 73 73 20 74 6f 20 22 20 28 61 72 65 61 2d 64 ess to " (area-d
4980: 62 64 69 72 20 61 63 66 67 29 29 29 29 0a 3b 3b bdir acfg)))).;;
4990: 3b 20 20 20 20 20 28 6d 61 6b 65 2d 64 62 64 61 ; (make-dbda
49a0: 74 20 64 62 68 3a 20 64 62 20 66 6e 61 6d 65 3a t dbh: db fname:
49b0: 20 66 6e 61 6d 65 20 77 72 69 74 65 2d 61 63 63 fname write-acc
49c0: 65 73 73 3a 20 77 72 69 74 65 2d 61 63 63 65 73 ess: write-acces
49d0: 73 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b s))).;;; .;;; ;;
49e0: 20 54 68 69 73 20 69 73 20 61 20 6c 6f 77 2d 6c This is a low-l
49f0: 65 76 65 6c 20 63 6f 6d 6d 61 6e 64 20 74 6f 20 evel command to
4a00: 72 65 74 72 69 65 76 65 20 6f 72 20 74 6f 20 70 retrieve or to p
4a10: 72 65 70 61 72 65 2c 20 73 61 76 65 20 61 6e 64 repare, save and
4a20: 20 72 65 74 75 72 6e 20 61 20 70 72 65 70 61 72 return a prepar
4a30: 65 64 20 73 74 61 74 6d 65 6e 74 0a 3b 3b 3b 20 ed statment.;;;
4a40: 3b 3b 20 79 6f 75 20 6d 75 73 74 20 65 78 74 72 ;; you must extr
4a50: 61 63 74 20 74 68 65 20 64 62 20 68 61 6e 64 6c act the db handl
4a60: 65 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 e.;;; ;;.;;; (de
4a70: 66 69 6e 65 20 28 67 65 74 2d 73 74 68 20 64 62 fine (get-sth db
4a80: 20 63 61 63 68 65 20 73 74 6d 74 29 0a 3b 3b 3b cache stmt).;;;
4a90: 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 (if (hash-tab
4aa0: 6c 65 2d 65 78 69 73 74 73 3f 20 63 61 63 68 65 le-exists? cache
4ab0: 20 73 74 6d 74 29 0a 3b 3b 3b 20 20 20 20 20 20 stmt).;;;
4ac0: 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 3b 3b 20 (begin.;;; .;;
4ad0: 28 70 72 69 6e 74 20 22 52 65 75 73 69 6e 67 20 (print "Reusing
4ae0: 63 61 63 68 65 64 20 73 74 6d 74 20 66 6f 72 20 cached stmt for
4af0: 22 20 73 74 6d 74 29 0a 3b 3b 3b 20 09 28 68 61 " stmt).;;; .(ha
4b00: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4b10: 61 75 6c 74 20 63 61 63 68 65 20 73 74 6d 74 20 ault cache stmt
4b20: 23 66 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 #f)).;;; (
4b30: 6c 65 74 20 28 28 73 74 68 20 28 73 71 6c 69 74 let ((sth (sqlit
4b40: 65 33 3a 70 72 65 70 61 72 65 20 64 62 20 73 74 e3:prepare db st
4b50: 6d 74 29 29 29 0a 3b 3b 3b 20 09 28 68 61 73 68 mt))).;;; .(hash
4b60: 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 61 63 68 -table-set! cach
4b70: 65 20 73 74 6d 74 20 73 74 68 29 0a 3b 3b 3b 20 e stmt sth).;;;
4b80: 09 3b 3b 20 28 70 72 69 6e 74 20 22 70 72 65 70 .;; (print "prep
4b90: 61 72 65 64 20 73 74 6d 74 20 66 6f 72 20 22 20 ared stmt for "
4ba0: 73 74 6d 74 29 0a 3b 3b 3b 20 09 73 74 68 29 29 stmt).;;; .sth))
4bb0: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 61 20 ).;;; .;;; ;; a
4bc0: 6c 69 74 74 6c 65 20 6d 6f 72 65 20 65 78 70 65 little more expe
4bd0: 6e 73 69 76 65 20 62 75 74 20 64 6f 65 73 20 61 nsive but does a
4be0: 6c 6c 20 74 68 65 20 74 65 64 69 6f 75 73 20 64 ll the tedious d
4bf0: 65 66 65 72 65 6e 63 69 6e 67 20 2d 20 6f 6e 6c eferencing - onl
4c00: 79 20 75 73 65 20 69 66 20 79 6f 75 20 64 6f 6e y use if you don
4c10: 27 74 20 61 6c 72 65 61 64 79 0a 3b 3b 3b 20 3b 't already.;;; ;
4c20: 3b 20 68 61 76 65 20 64 62 64 61 74 20 61 6e 64 ; have dbdat and
4c30: 20 64 62 20 73 69 74 74 69 6e 67 20 61 72 6f 75 db sitting arou
4c40: 6e 64 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 nd.;;; ;;.;;; (d
4c50: 65 66 69 6e 65 20 28 66 75 6c 6c 2d 67 65 74 2d efine (full-get-
4c60: 73 74 68 20 61 63 66 67 20 66 6e 61 6d 65 20 73 sth acfg fname s
4c70: 74 6d 74 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a tmt).;;; (let*
4c80: 20 28 28 64 62 64 61 74 20 20 28 67 65 74 2d 64 ((dbdat (get-d
4c90: 62 68 20 61 63 66 67 20 66 6e 61 6d 65 29 29 0a bh acfg fname)).
4ca0: 3b 3b 3b 20 09 20 28 64 62 20 20 20 20 20 28 64 ;;; . (db (d
4cb0: 62 64 61 74 2d 64 62 68 20 64 62 64 61 74 29 29 bdat-dbh dbdat))
4cc0: 0a 3b 3b 3b 20 09 20 28 73 74 68 73 20 20 20 28 .;;; . (sths (
4cd0: 64 62 64 61 74 2d 73 74 68 73 20 64 62 64 61 74 dbdat-sths dbdat
4ce0: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 67 65 74 ))).;;; (get
4cf0: 2d 73 74 68 20 64 62 20 73 74 68 73 20 73 74 6d -sth db sths stm
4d00: 74 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b t))).;;; .;;; ;;
4d10: 20 77 72 69 74 65 20 74 6f 20 61 20 64 62 0a 3b write to a db.;
4d20: 3b 3b 20 3b 3b 20 61 63 66 67 3a 20 61 72 65 61 ;; ;; acfg: area
4d30: 20 64 61 74 61 0a 3b 3b 3b 20 3b 3b 20 72 64 61 data.;;; ;; rda
4d40: 74 3a 20 72 65 71 75 65 73 74 20 64 61 74 61 0a t: request data.
4d50: 3b 3b 3b 20 3b 3b 20 68 64 61 74 3a 20 28 68 6f ;;; ;; hdat: (ho
4d60: 73 74 20 2e 20 70 6f 72 74 29 0a 3b 3b 3b 20 3b st . port).;;; ;
4d70: 3b 0a 3b 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 ;.;;; ;; (define
4d80: 20 28 64 62 77 72 69 74 65 20 61 63 66 67 20 72 (dbwrite acfg r
4d90: 64 61 74 20 68 64 61 74 20 64 61 74 61 2d 69 6e dat hdat data-in
4da0: 29 0a 3b 3b 3b 20 3b 3b 20 20 20 28 6c 65 74 2a ).;;; ;; (let*
4db0: 20 28 28 64 62 6e 61 6d 65 20 28 63 61 72 20 64 ((dbname (car d
4dc0: 61 74 61 2d 69 6e 29 29 0a 3b 3b 3b 20 3b 3b 20 ata-in)).;;; ;;
4dd0: 09 20 28 64 62 64 61 74 20 20 28 67 65 74 2d 64 . (dbdat (get-d
4de0: 62 68 20 61 63 66 67 20 64 62 6e 61 6d 65 29 29 bh acfg dbname))
4df0: 0a 3b 3b 3b 20 3b 3b 20 09 20 28 64 62 20 20 20 .;;; ;; . (db
4e00: 20 20 28 64 62 64 61 74 2d 64 62 68 20 64 62 64 (dbdat-dbh dbd
4e10: 61 74 29 29 0a 3b 3b 3b 20 3b 3b 20 09 20 28 73 at)).;;; ;; . (s
4e20: 74 68 73 20 20 20 28 64 62 64 61 74 2d 73 74 68 ths (dbdat-sth
4e30: 73 20 64 62 64 61 74 29 29 0a 3b 3b 3b 20 3b 3b s dbdat)).;;; ;;
4e40: 20 09 20 28 73 74 6d 74 20 20 20 28 63 61 6c 6c . (stmt (call
4e50: 64 61 74 2d 6f 62 6a 20 72 64 61 74 29 29 0a 3b dat-obj rdat)).;
4e60: 3b 3b 20 3b 3b 20 09 20 28 73 74 68 20 20 20 20 ;; ;; . (sth
4e70: 28 67 65 74 2d 73 74 68 20 64 62 20 73 74 68 73 (get-sth db sths
4e80: 20 73 74 6d 74 29 29 0a 3b 3b 3b 20 3b 3b 20 09 stmt)).;;; ;; .
4e90: 20 28 64 61 74 61 20 20 20 28 63 64 72 20 64 61 (data (cdr da
4ea0: 74 61 2d 69 6e 29 29 29 0a 3b 3b 3b 20 3b 3b 20 ta-in))).;;; ;;
4eb0: 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 6e 61 (print "dbna
4ec0: 6d 65 3a 20 22 20 64 62 6e 61 6d 65 20 22 20 61 me: " dbname " a
4ed0: 63 66 67 3a 20 22 20 61 63 66 67 20 22 20 72 64 cfg: " acfg " rd
4ee0: 61 74 3a 20 22 20 28 63 61 6c 6c 64 61 74 2d 3e at: " (calldat->
4ef0: 61 6c 69 73 74 20 72 64 61 74 29 20 22 20 68 64 alist rdat) " hd
4f00: 61 74 3a 20 22 20 68 64 61 74 20 22 20 64 61 74 at: " hdat " dat
4f10: 61 3a 20 22 20 64 61 74 61 29 0a 3b 3b 3b 20 3b a: " data).;;; ;
4f20: 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 ; (print "db
4f30: 64 61 74 3a 20 22 20 28 64 62 64 61 74 2d 3e 61 dat: " (dbdat->a
4f40: 6c 69 73 74 20 64 62 64 61 74 29 29 0a 3b 3b 3b list dbdat)).;;;
4f50: 20 3b 3b 20 20 20 20 20 28 61 70 70 6c 79 20 73 ;; (apply s
4f60: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 73 qlite3:execute s
4f70: 74 68 20 64 61 74 61 29 0a 3b 3b 3b 20 3b 3b 20 th data).;;; ;;
4f80: 20 20 20 20 28 73 61 76 65 2d 64 62 68 20 61 63 (save-dbh ac
4f90: 66 67 20 64 62 6e 61 6d 65 20 64 62 64 61 74 29 fg dbname dbdat)
4fa0: 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 23 74 0a 3b .;;; ;; #t.;
4fb0: 3b 3b 20 3b 3b 20 20 20 20 20 29 29 0a 3b 3b 3b ;; ;; )).;;;
4fc0: 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 66 .;;; (define (f
4fd0: 69 6e 61 6c 69 7a 65 2d 61 6c 6c 2d 64 62 2d 68 inalize-all-db-h
4fe0: 61 6e 64 6c 65 73 20 61 63 66 67 29 0a 3b 3b 3b andles acfg).;;;
4ff0: 20 20 20 28 6c 65 74 2a 20 28 28 64 62 68 61 6e (let* ((dbhan
5000: 64 6c 65 73 20 28 61 72 65 61 2d 64 62 68 61 6e dles (area-dbhan
5010: 64 6c 65 73 20 61 63 66 67 29 29 20 20 3b 3b 20 dles acfg)) ;;
5020: 64 62 68 61 6e 64 6c 65 73 20 69 73 20 68 61 73 dbhandles is has
5030: 68 20 6f 66 20 66 6e 61 6d 65 20 3d 3d 3e 20 64 h of fname ==> d
5040: 62 64 61 74 0a 3b 3b 3b 20 09 20 28 6e 75 6d 20 bdat.;;; . (num
5050: 20 20 20 20 20 20 30 29 29 0a 3b 3b 3b 20 20 20 0)).;;;
5060: 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 (for-each.;;;
5070: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 72 (lambda (ar
5080: 65 61 2d 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 20 ea-name).;;;
5090: 20 20 20 20 28 70 72 69 6e 74 20 22 43 6c 6f 73 (print "Clos
50a0: 69 6e 67 20 68 61 6e 64 6c 65 73 20 66 6f 72 20 ing handles for
50b0: 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 3b 3b 3b " area-name).;;;
50c0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 (let ((d
50d0: 62 64 61 74 73 20 28 68 61 73 68 2d 74 61 62 6c bdats (hash-tabl
50e0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 64 62 e-ref/default db
50f0: 68 61 6e 64 6c 65 73 20 61 72 65 61 2d 6e 61 6d handles area-nam
5100: 65 20 27 28 29 29 29 29 0a 3b 3b 3b 20 09 20 28 e '()))).;;; . (
5110: 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 09 20 20 for-each.;;; .
5120: 28 6c 61 6d 62 64 61 20 28 64 62 64 61 74 29 0a (lambda (dbdat).
5130: 3b 3b 3b 20 09 20 20 20 20 3b 3b 20 66 69 72 73 ;;; . ;; firs
5140: 74 20 63 6c 6f 73 65 20 61 6c 6c 20 73 74 61 74 t close all stat
5150: 65 6d 65 6e 74 20 68 61 6e 64 6c 65 73 0a 3b 3b ement handles.;;
5160: 3b 20 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ; . (for-each
5170: 0a 3b 3b 3b 20 09 20 20 20 20 20 28 6c 61 6d 62 .;;; . (lamb
5180: 64 61 20 28 73 74 68 29 0a 3b 3b 3b 20 09 20 20 da (sth).;;; .
5190: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 (sqlite3:fi
51a0: 6e 61 6c 69 7a 65 21 20 73 74 68 29 0a 3b 3b 3b nalize! sth).;;;
51b0: 20 09 20 20 20 20 20 20 20 28 73 65 74 21 20 6e . (set! n
51c0: 75 6d 20 28 2b 20 6e 75 6d 20 31 29 29 29 0a 3b um (+ num 1))).;
51d0: 3b 3b 20 09 20 20 20 20 20 28 68 61 73 68 2d 74 ;; . (hash-t
51e0: 61 62 6c 65 2d 76 61 6c 75 65 73 20 28 64 62 64 able-values (dbd
51f0: 61 74 2d 73 74 68 73 20 64 62 64 61 74 29 29 29 at-sths dbdat)))
5200: 0a 3b 3b 3b 20 09 20 20 20 20 3b 3b 20 6e 6f 77 .;;; . ;; now
5210: 20 63 6c 6f 73 65 20 74 68 65 20 64 62 68 0a 3b close the dbh.;
5220: 3b 3b 20 09 20 20 20 20 28 73 65 74 21 20 6e 75 ;; . (set! nu
5230: 6d 20 28 2b 20 6e 75 6d 20 31 29 29 0a 3b 3b 3b m (+ num 1)).;;;
5240: 20 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 . (sqlite3:f
5250: 69 6e 61 6c 69 7a 65 21 20 28 64 62 64 61 74 2d inalize! (dbdat-
5260: 64 62 68 20 64 62 64 61 74 29 29 29 0a 3b 3b 3b dbh dbdat))).;;;
5270: 20 09 20 20 64 62 64 61 74 73 29 29 29 0a 3b 3b . dbdats))).;;
5280: 3b 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 ; (hash-tab
5290: 6c 65 2d 6b 65 79 73 20 64 62 68 61 6e 64 6c 65 le-keys dbhandle
52a0: 73 29 29 0a 3b 3b 3b 20 20 20 20 20 28 70 72 69 s)).;;; (pri
52b0: 6e 74 20 22 46 49 4e 41 4c 49 5a 45 44 20 22 20 nt "FINALIZED "
52c0: 6e 75 6d 20 22 20 64 62 68 61 6e 64 6c 65 73 22 num " dbhandles"
52d0: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d ))).;;; .;;; ;;=
52e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5320: 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 57 20 4f =====.;;; ;; W O
5330: 20 52 20 4b 20 20 20 51 20 55 20 45 20 55 20 45 R K Q U E U E
5340: 20 20 20 48 20 41 20 4e 20 44 20 4c 20 49 20 4e H A N D L I N
5350: 20 47 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d G .;;; ;;======
5360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53a0: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e .;;; .;;; (defin
53b0: 65 20 28 72 65 67 69 73 74 65 72 2d 64 62 2d 61 e (register-db-a
53c0: 73 2d 6d 69 6e 65 20 61 63 66 67 20 64 62 6e 61 s-mine acfg dbna
53d0: 6d 65 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 28 me).;;; (let (
53e0: 28 68 74 20 28 61 72 65 61 2d 64 62 73 20 61 63 (ht (area-dbs ac
53f0: 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 fg))).;;; (i
5400: 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 f (not (hash-tab
5410: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 le-ref/default h
5420: 74 20 64 62 6e 61 6d 65 20 23 66 29 29 0a 3b 3b t dbname #f)).;;
5430: 3b 20 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ; .(hash-table-s
5440: 65 74 21 20 68 74 20 64 62 6e 61 6d 65 20 28 72 et! ht dbname (r
5450: 61 6e 64 6f 6d 20 31 30 30 30 30 29 29 29 29 29 andom 10000)))))
5460: 0a 3b 3b 3b 20 09 0a 3b 3b 3b 20 28 64 65 66 69 .;;; ..;;; (defi
5470: 6e 65 20 28 77 6f 72 6b 2d 71 75 65 75 65 2d 61 ne (work-queue-a
5480: 64 64 20 61 63 66 67 20 66 6e 61 6d 65 20 77 69 dd acfg fname wi
5490: 74 65 6d 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a tem).;;; (let*
54a0: 20 28 28 77 6f 72 6b 2d 71 75 65 75 65 2d 73 74 ((work-queue-st
54b0: 61 72 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c art (current-mil
54c0: 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 liseconds)).;;;
54d0: 09 20 28 61 63 74 69 6f 6e 20 20 20 20 20 20 20 . (action
54e0: 20 20 20 20 28 77 69 74 65 6d 2d 61 63 74 69 6f (witem-actio
54f0: 6e 20 77 69 74 65 6d 29 29 20 3b 3b 20 4e 42 20 n witem)) ;; NB
5500: 74 68 65 20 61 63 74 69 6f 6e 20 69 73 20 74 68 the action is th
5510: 65 20 69 6e 64 65 78 20 69 6e 74 6f 20 74 68 65 e index into the
5520: 20 72 64 61 74 20 61 63 74 69 6f 6e 73 0a 3b 3b rdat actions.;;
5530: 3b 20 09 20 28 71 64 61 74 20 20 20 20 20 20 20 ; . (qdat
5540: 20 20 20 20 20 20 28 6f 72 20 28 68 61 73 68 2d (or (hash-
5550: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5560: 74 20 28 61 72 65 61 2d 77 71 75 65 75 65 73 20 t (area-wqueues
5570: 61 63 66 67 29 20 66 6e 61 6d 65 20 23 66 29 0a acfg) fname #f).
5580: 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 20 28 6c ;;; ... (l
5590: 65 74 20 28 28 6e 65 77 71 64 61 74 20 28 6d 61 et ((newqdat (ma
55a0: 6b 65 2d 71 64 61 74 29 29 29 0a 3b 3b 3b 20 09 ke-qdat))).;;; .
55b0: 09 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ... (hash-table-
55c0: 73 65 74 21 20 28 61 72 65 61 2d 77 71 75 65 75 set! (area-wqueu
55d0: 65 73 20 61 63 66 67 29 20 66 6e 61 6d 65 20 6e es acfg) fname n
55e0: 65 77 71 64 61 74 29 0a 3b 3b 3b 20 09 09 09 09 ewqdat).;;; ....
55f0: 20 6e 65 77 71 64 61 74 29 29 29 0a 3b 3b 3b 20 newqdat))).;;;
5600: 09 20 28 72 64 61 74 20 20 20 20 20 20 20 20 20 . (rdat
5610: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
5620: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 61 72 65 ref/default (are
5630: 61 2d 72 74 61 62 6c 65 20 61 63 66 67 29 20 61 a-rtable acfg) a
5640: 63 74 69 6f 6e 20 23 66 29 29 29 0a 3b 3b 3b 20 ction #f))).;;;
5650: 20 20 20 20 28 69 66 20 72 64 61 74 0a 3b 3b 3b (if rdat.;;;
5660: 20 09 28 71 75 65 75 65 2d 61 64 64 21 0a 3b 3b .(queue-add!.;;
5670: 3b 20 09 20 28 63 61 73 65 20 28 63 61 6c 6c 64 ; . (case (calld
5680: 61 74 2d 63 74 79 70 65 20 72 64 61 74 29 0a 3b at-ctype rdat).;
5690: 3b 3b 20 09 20 20 20 28 28 64 62 77 72 69 74 65 ;; . ((dbwrite
56a0: 29 20 20 20 28 72 65 67 69 73 74 65 72 2d 64 62 ) (register-db
56b0: 2d 61 73 2d 6d 69 6e 65 20 61 63 66 67 20 66 6e -as-mine acfg fn
56c0: 61 6d 65 29 28 71 64 61 74 2d 77 72 69 74 65 71 ame)(qdat-writeq
56d0: 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 20 20 20 qdat)).;;; .
56e0: 28 28 64 62 72 65 61 64 29 20 20 20 20 28 72 65 ((dbread) (re
56f0: 67 69 73 74 65 72 2d 64 62 2d 61 73 2d 6d 69 6e gister-db-as-min
5700: 65 20 61 63 66 67 20 66 6e 61 6d 65 29 28 71 64 e acfg fname)(qd
5710: 61 74 2d 72 65 61 64 71 20 20 71 64 61 74 29 29 at-readq qdat))
5720: 0a 3b 3b 3b 20 09 20 20 20 28 28 64 62 72 77 29 .;;; . ((dbrw)
5730: 20 20 20 20 20 20 28 72 65 67 69 73 74 65 72 2d (register-
5740: 64 62 2d 61 73 2d 6d 69 6e 65 20 61 63 66 67 20 db-as-mine acfg
5750: 66 6e 61 6d 65 29 28 71 64 61 74 2d 72 77 71 20 fname)(qdat-rwq
5760: 20 20 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 20 qdat)).;;; .
5770: 20 20 28 28 6f 73 6c 6f 6e 67 29 20 20 20 20 28 ((oslong) (
5780: 71 64 61 74 2d 6f 73 6c 6f 6e 67 20 71 64 61 74 qdat-oslong qdat
5790: 29 29 0a 3b 3b 3b 20 09 20 20 20 28 28 6f 73 73 )).;;; . ((oss
57a0: 68 6f 72 74 29 20 20 20 28 71 64 61 74 2d 6f 73 hort) (qdat-os
57b0: 73 68 6f 72 74 20 71 64 61 74 29 29 0a 3b 3b 3b short qdat)).;;;
57c0: 20 09 20 20 20 28 28 66 75 6c 6c 2d 70 69 6e 67 . ((full-ping
57d0: 29 20 28 71 64 61 74 2d 6d 69 73 63 20 20 71 64 ) (qdat-misc qd
57e0: 61 74 29 29 0a 3b 3b 3b 20 09 20 20 20 28 65 6c at)).;;; . (el
57f0: 73 65 0a 3b 3b 3b 20 09 20 20 20 20 28 70 72 69 se.;;; . (pri
5800: 6e 74 20 22 45 52 52 4f 52 3a 20 6e 6f 20 71 75 nt "ERROR: no qu
5810: 65 75 65 20 66 6f 72 20 22 20 61 63 74 69 6f 6e eue for " action
5820: 20 22 2e 20 41 64 64 69 6e 67 20 74 6f 20 64 62 ". Adding to db
5830: 77 72 69 74 65 20 71 75 65 75 65 2e 22 29 0a 3b write queue.").;
5840: 3b 3b 20 09 20 20 20 20 28 71 64 61 74 2d 77 72 ;; . (qdat-wr
5850: 69 74 65 71 20 71 64 61 74 29 29 29 0a 3b 3b 3b iteq qdat))).;;;
5860: 20 09 20 77 69 74 65 6d 29 0a 3b 3b 3b 20 09 28 . witem).;;; .(
5870: 63 61 73 65 20 61 63 74 69 6f 6e 0a 3b 3b 3b 20 case action.;;;
5880: 09 20 20 28 28 66 75 6c 6c 2d 70 69 6e 67 29 28 . ((full-ping)(
5890: 71 64 61 74 2d 6d 69 73 63 20 71 64 61 74 29 29 qdat-misc qdat))
58a0: 0a 3b 3b 3b 20 09 20 20 28 65 6c 73 65 0a 3b 3b .;;; . (else.;;
58b0: 3b 20 09 20 20 20 28 70 72 69 6e 74 20 22 45 52 ; . (print "ER
58c0: 52 4f 52 3a 20 4e 6f 20 61 63 74 69 6f 6e 20 22 ROR: No action "
58d0: 20 61 63 74 69 6f 6e 20 22 20 77 61 73 20 72 65 action " was re
58e0: 67 69 73 74 65 72 65 64 22 29 29 29 29 0a 3b 3b gistered")))).;;
58f0: 3b 20 20 20 20 20 28 73 64 62 67 3e 20 22 77 6f ; (sdbg> "wo
5900: 72 6b 2d 71 75 65 75 65 2d 61 64 64 22 20 22 71 rk-queue-add" "q
5910: 75 65 75 65 2d 61 64 64 22 20 77 6f 72 6b 2d 71 ueue-add" work-q
5920: 75 65 75 65 2d 73 74 61 72 74 20 23 66 20 23 66 ueue-start #f #f
5930: 29 0a 3b 3b 3b 20 20 20 20 20 23 74 29 29 20 3b ).;;; #t)) ;
5940: 3b 20 66 6f 72 20 6e 6f 77 2c 20 73 69 6d 70 6c ; for now, simpl
5950: 79 20 72 65 74 75 72 6e 20 23 74 20 74 6f 20 69 y return #t to i
5960: 6e 64 69 63 61 74 65 20 72 65 71 75 65 73 74 20 ndicate request
5970: 67 6f 74 20 74 6f 20 74 68 65 20 71 75 65 75 65 got to the queue
5980: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e .;;; .;;; (defin
5990: 65 20 28 64 6f 71 75 65 75 65 20 61 63 66 67 20 e (doqueue acfg
59a0: 71 20 66 6e 61 6d 65 20 64 62 64 61 74 20 64 62 q fname dbdat db
59b0: 68 29 0a 3b 3b 3b 20 20 20 3b 3b 20 28 70 72 69 h).;;; ;; (pri
59c0: 6e 74 20 22 64 6f 71 75 65 75 65 3a 20 22 20 66 nt "doqueue: " f
59d0: 6e 61 6d 65 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 name).;;; (let
59e0: 2a 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 * ((start-time (
59f0: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
5a00: 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 28 71 6c onds)).;;; . (ql
5a10: 65 6e 20 20 20 20 20 20 20 28 71 75 65 75 65 2d en (queue-
5a20: 6c 65 6e 67 74 68 20 71 29 29 29 0a 3b 3b 3b 20 length q))).;;;
5a30: 20 20 20 20 28 69 66 20 28 3e 20 71 6c 65 6e 20 (if (> qlen
5a40: 31 29 0a 3b 3b 3b 20 09 28 70 72 69 6e 74 20 22 1).;;; .(print "
5a50: 50 72 6f 63 65 73 73 69 6e 67 20 71 75 65 75 65 Processing queue
5a60: 20 6f 66 20 6c 65 6e 67 74 68 20 22 20 71 6c 65 of length " qle
5a70: 6e 29 29 0a 3b 3b 3b 20 20 20 20 20 28 6c 65 74 n)).;;; (let
5a80: 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 20 loop ((count
5a90: 20 20 20 30 29 0a 3b 3b 3b 20 09 20 20 20 20 20 0).;;; .
5aa0: 20 20 28 72 65 73 70 6f 6e 73 65 73 20 27 28 29 (responses '()
5ab0: 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 6c 65 )).;;; (le
5ac0: 74 20 28 28 64 65 6c 74 61 20 28 2d 20 28 63 75 t ((delta (- (cu
5ad0: 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
5ae0: 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 ds) start-time))
5af0: 29 0a 3b 3b 3b 20 09 28 69 66 20 28 6f 72 20 28 ).;;; .(if (or (
5b00: 71 75 65 75 65 2d 65 6d 70 74 79 3f 20 71 29 0a queue-empty? q).
5b10: 3b 3b 3b 20 09 09 28 3e 20 64 65 6c 74 61 20 34 ;;; ..(> delta 4
5b20: 30 30 29 29 20 3b 3b 20 73 74 6f 70 20 77 6f 72 00)) ;; stop wor
5b30: 6b 69 6e 67 20 6f 6e 20 74 68 69 73 20 71 75 65 king on this que
5b40: 75 65 20 61 66 74 65 72 20 34 30 30 6d 73 20 68 ue after 400ms h
5b50: 61 76 65 20 70 61 73 73 65 64 0a 3b 3b 3b 20 09 ave passed.;;; .
5b60: 20 20 20 20 28 6c 69 73 74 20 63 6f 75 6e 74 20 (list count
5b70: 64 65 6c 74 61 20 72 65 73 70 6f 6e 73 65 73 29 delta responses)
5b80: 20 3b 3b 20 72 65 74 75 72 6e 20 63 6f 75 6e 74 ;; return count
5b90: 2c 20 64 65 6c 74 61 20 61 6e 64 20 72 65 73 70 , delta and resp
5ba0: 6f 6e 73 65 73 20 6c 69 73 74 0a 3b 3b 3b 20 09 onses list.;;; .
5bb0: 20 20 20 20 28 6c 65 74 2a 20 28 28 77 69 74 65 (let* ((wite
5bc0: 6d 20 20 28 71 75 65 75 65 2d 72 65 6d 6f 76 65 m (queue-remove
5bd0: 21 20 71 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 ! q)).;;; .. (
5be0: 61 63 74 69 6f 6e 20 28 77 69 74 65 6d 2d 61 63 action (witem-ac
5bf0: 74 69 6f 6e 20 77 69 74 65 6d 29 29 0a 3b 3b 3b tion witem)).;;;
5c00: 20 09 09 20 20 20 28 72 64 61 74 20 20 20 28 77 .. (rdat (w
5c10: 69 74 65 6d 2d 72 64 61 74 20 20 20 77 69 74 65 item-rdat wite
5c20: 6d 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 73 74 m)).;;; .. (st
5c30: 6d 74 20 20 20 28 63 61 6c 6c 64 61 74 2d 6f 62 mt (calldat-ob
5c40: 6a 20 72 64 61 74 29 29 0a 3b 3b 3b 20 09 09 20 j rdat)).;;; ..
5c50: 20 20 28 73 74 68 20 20 20 20 28 66 75 6c 6c 2d (sth (full-
5c60: 67 65 74 2d 73 74 68 20 61 63 66 67 20 66 6e 61 get-sth acfg fna
5c70: 6d 65 20 73 74 6d 74 29 29 0a 3b 3b 3b 20 09 09 me stmt)).;;; ..
5c80: 20 20 20 28 63 74 79 70 65 20 20 28 63 61 6c 6c (ctype (call
5c90: 64 61 74 2d 63 74 79 70 65 20 72 64 61 74 29 29 dat-ctype rdat))
5ca0: 0a 3b 3b 3b 20 09 09 20 20 20 28 64 61 74 61 20 .;;; .. (data
5cb0: 20 20 28 77 69 74 65 6d 2d 64 61 74 61 20 20 20 (witem-data
5cc0: 77 69 74 65 6d 29 29 0a 3b 3b 3b 20 09 09 20 20 witem)).;;; ..
5cd0: 20 28 63 6f 6f 6b 69 65 20 28 77 69 74 65 6d 2d (cookie (witem-
5ce0: 63 6f 6f 6b 69 65 20 77 69 74 65 6d 29 29 29 0a cookie witem))).
5cf0: 3b 3b 3b 20 09 20 20 20 20 20 20 3b 3b 20 64 6f ;;; . ;; do
5d00: 20 74 68 65 20 70 72 6f 63 65 73 73 69 6e 67 20 the processing
5d10: 61 6e 64 20 73 61 76 65 20 74 68 65 20 72 65 73 and save the res
5d20: 75 6c 74 20 69 6e 20 77 69 74 65 6d 2d 72 65 73 ult in witem-res
5d30: 75 6c 74 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 ult.;;; . (
5d40: 77 69 74 65 6d 2d 72 65 73 75 6c 74 2d 73 65 74 witem-result-set
5d50: 21 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 77 69 !.;;; . wi
5d60: 74 65 6d 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 tem.;;; .
5d70: 28 63 61 73 65 20 63 74 79 70 65 20 3b 3b 20 61 (case ctype ;; a
5d80: 63 74 69 6f 6e 0a 3b 3b 3b 20 09 09 20 28 28 6e ction.;;; .. ((n
5d90: 6f 62 6c 6f 63 6b 77 72 69 74 65 29 20 3b 3b 20 oblockwrite) ;;
5da0: 62 6c 69 6e 64 20 77 72 69 74 65 2c 20 6e 6f 20 blind write, no
5db0: 61 63 6b 20 6f 66 20 73 75 63 63 65 73 73 20 72 ack of success r
5dc0: 65 74 75 72 6e 65 64 0a 3b 3b 3b 20 09 09 20 20 eturned.;;; ..
5dd0: 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 (apply sqlite3:e
5de0: 78 65 63 75 74 65 20 73 74 68 20 64 61 74 61 29 xecute sth data)
5df0: 0a 3b 3b 3b 20 09 09 20 20 28 73 71 6c 69 74 65 .;;; .. (sqlite
5e00: 33 3a 6c 61 73 74 2d 69 6e 73 65 72 74 2d 72 6f 3:last-insert-ro
5e10: 77 69 64 20 64 62 68 29 29 0a 3b 3b 3b 20 09 09 wid dbh)).;;; ..
5e20: 20 28 28 64 62 77 72 69 74 65 29 20 20 20 20 20 ((dbwrite)
5e30: 20 3b 3b 20 62 6c 6f 63 6b 69 6e 67 20 77 72 69 ;; blocking wri
5e40: 74 65 20 20 20 0a 3b 3b 3b 20 09 09 20 20 28 61 te .;;; .. (a
5e50: 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 pply sqlite3:exe
5e60: 63 75 74 65 20 73 74 68 20 64 61 74 61 29 0a 3b cute sth data).;
5e70: 3b 3b 20 09 09 20 20 23 74 29 0a 3b 3b 3b 20 09 ;; .. #t).;;; .
5e80: 09 20 28 28 64 62 72 65 61 64 29 20 3b 3b 20 54 . ((dbread) ;; T
5e90: 4f 44 4f 3a 20 63 6f 6e 73 69 64 65 72 20 62 72 ODO: consider br
5ea0: 65 61 6b 69 6e 67 20 74 68 69 73 20 75 70 20 61 eaking this up a
5eb0: 6e 64 20 73 68 69 70 70 69 6e 67 20 69 6e 20 70 nd shipping in p
5ec0: 69 65 63 65 73 20 66 6f 72 20 6c 61 72 67 65 20 ieces for large
5ed0: 71 75 65 72 79 0a 3b 3b 3b 20 09 09 20 20 28 61 query.;;; .. (a
5ee0: 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 6d 61 70 pply sqlite3:map
5ef0: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 78 20 78 -row (lambda x x
5f00: 29 20 73 74 68 20 64 61 74 61 29 29 0a 3b 3b 3b ) sth data)).;;;
5f10: 20 09 09 20 28 28 66 75 6c 6c 2d 70 69 6e 67 29 .. ((full-ping)
5f20: 20 20 27 66 75 6c 6c 2d 70 69 6e 67 29 0a 3b 3b 'full-ping).;;
5f30: 3b 20 09 09 20 28 65 6c 73 65 20 28 70 72 69 6e ; .. (else (prin
5f40: 74 20 22 4e 6f 74 20 72 65 61 64 79 20 66 6f 72 t "Not ready for
5f50: 20 61 63 74 69 6f 6e 20 22 20 61 63 74 69 6f 6e action " action
5f60: 29 20 23 66 29 29 29 0a 3b 3b 3b 20 09 20 20 20 ) #f))).;;; .
5f70: 20 20 20 28 6c 6f 6f 70 20 28 61 64 64 31 20 63 (loop (add1 c
5f80: 6f 75 6e 74 29 0a 3b 3b 3b 20 09 09 20 20 20 20 ount).;;; ..
5f90: 28 69 66 20 63 6f 6f 6b 69 65 0a 3b 3b 3b 20 09 (if cookie.;;; .
5fa0: 09 09 28 63 6f 6e 73 20 77 69 74 65 6d 20 72 65 ..(cons witem re
5fb0: 73 70 6f 6e 73 65 73 29 0a 3b 3b 3b 20 09 09 09 sponses).;;; ...
5fc0: 72 65 73 70 6f 6e 73 65 73 29 29 29 29 29 29 29 responses)))))))
5fd0: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 64 6f ).;;; .;;; ;; do
5fe0: 20 75 70 20 74 6f 20 34 30 30 6d 73 20 6f 66 20 up to 400ms of
5ff0: 70 72 6f 63 65 73 73 69 6e 67 20 6f 6e 20 65 61 processing on ea
6000: 63 68 20 71 75 65 75 65 0a 3b 3b 3b 20 3b 3b 20 ch queue.;;; ;;
6010: 2d 20 74 68 65 20 77 6f 72 6b 2d 71 75 65 75 65 - the work-queue
6020: 2d 70 72 6f 63 65 73 73 6f 72 20 77 69 6c 6c 20 -processor will
6030: 61 6c 6c 6f 77 20 74 68 65 20 6d 61 78 20 31 32 allow the max 12
6040: 30 30 6d 73 20 6f 66 20 77 6f 72 6b 20 74 6f 20 00ms of work to
6050: 63 6f 6d 70 6c 65 74 65 20 62 75 74 20 69 74 20 complete but it
6060: 77 69 6c 6c 20 66 6c 61 67 20 61 73 20 6f 76 65 will flag as ove
6070: 72 6c 6f 61 64 65 64 0a 3b 3b 3b 20 3b 3b 20 0a rloaded.;;; ;; .
6080: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 70 72 6f ;;; (define (pro
6090: 63 65 73 73 2d 64 62 2d 71 75 65 72 69 65 73 20 cess-db-queries
60a0: 61 63 66 67 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 acfg fname).;;;
60b0: 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
60c0: 65 2d 65 78 69 73 74 73 3f 20 28 61 72 65 61 2d e-exists? (area-
60d0: 77 71 75 65 75 65 73 20 61 63 66 67 29 20 66 6e wqueues acfg) fn
60e0: 61 6d 65 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 ame).;;; (
60f0: 6c 65 74 2a 20 28 28 70 72 6f 63 65 73 73 2d 64 let* ((process-d
6100: 62 2d 71 75 65 72 69 65 73 2d 73 74 61 72 74 2d b-queries-start-
6110: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 time (current-mi
6120: 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b lliseconds)).;;;
6130: 20 09 20 20 20 20 20 28 71 64 61 74 20 20 20 20 . (qdat
6140: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
6150: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
6160: 20 28 61 72 65 61 2d 77 71 75 65 75 65 73 20 61 (area-wqueues a
6170: 63 66 67 29 20 66 6e 61 6d 65 20 23 66 29 29 0a cfg) fname #f)).
6180: 3b 3b 3b 20 09 20 20 20 20 20 28 71 75 65 75 65 ;;; . (queue
6190: 2d 73 79 6d 2d 3e 71 75 65 75 65 20 28 6c 61 6d -sym->queue (lam
61a0: 62 64 61 20 28 71 75 65 75 65 2d 73 79 6d 29 0a bda (queue-sym).
61b0: 3b 3b 3b 20 09 09 09 09 20 28 63 61 73 65 20 71 ;;; .... (case q
61c0: 75 65 75 65 2d 73 79 6d 20 20 3b 3b 20 6c 6f 6f ueue-sym ;; loo
61d0: 6b 75 70 20 74 68 65 20 71 75 65 75 65 20 66 72 kup the queue fr
61e0: 6f 6d 20 71 64 61 74 20 67 69 76 65 6e 20 61 20 om qdat given a
61f0: 6e 61 6d 65 20 28 73 79 6d 62 6f 6c 29 0a 3b 3b name (symbol).;;
6200: 3b 20 09 09 09 09 20 20 20 28 28 77 71 75 65 75 ; .... ((wqueu
6210: 65 29 20 20 28 71 64 61 74 2d 77 72 69 74 65 71 e) (qdat-writeq
6220: 20 71 64 61 74 29 29 0a 3b 3b 3b 20 09 09 09 09 qdat)).;;; ....
6230: 20 20 20 28 28 72 71 75 65 75 65 29 20 20 28 71 ((rqueue) (q
6240: 64 61 74 2d 72 65 61 64 71 20 20 71 64 61 74 29 dat-readq qdat)
6250: 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 28 28 72 ).;;; .... ((r
6260: 77 71 75 65 75 65 29 20 28 71 64 61 74 2d 72 77 wqueue) (qdat-rw
6270: 71 20 20 20 20 71 64 61 74 29 29 0a 3b 3b 3b 20 q qdat)).;;;
6280: 09 09 09 09 20 20 20 28 28 6d 69 73 63 29 20 20 .... ((misc)
6290: 20 20 28 71 64 61 74 2d 6d 69 73 63 20 20 20 71 (qdat-misc q
62a0: 64 61 74 29 29 0a 3b 3b 3b 20 09 09 09 09 20 20 dat)).;;; ....
62b0: 20 28 65 6c 73 65 20 23 66 29 29 29 29 0a 3b 3b (else #f)))).;;
62c0: 3b 20 09 20 20 20 20 20 28 64 62 64 61 74 20 20 ; . (dbdat
62d0: 20 28 67 65 74 2d 64 62 68 20 61 63 66 67 20 66 (get-dbh acfg f
62e0: 6e 61 6d 65 29 29 0a 3b 3b 3b 20 09 20 20 20 20 name)).;;; .
62f0: 20 28 64 62 68 20 20 20 20 20 28 69 66 20 28 64 (dbh (if (d
6300: 62 64 61 74 3f 20 64 62 64 61 74 29 28 64 62 64 bdat? dbdat)(dbd
6310: 61 74 2d 64 62 68 20 64 62 64 61 74 29 20 23 66 at-dbh dbdat) #f
6320: 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 28 6e 6f )).;;; . (no
6330: 77 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 wtime (current-s
6340: 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 09 3b econds))).;;; .;
6350: 3b 20 68 61 6e 64 6c 65 20 74 68 65 20 71 75 65 ; handle the que
6360: 75 65 73 20 74 68 61 74 20 72 65 71 75 69 72 65 ues that require
6370: 20 61 20 74 72 61 6e 73 61 63 74 69 6f 6e 0a 3b a transaction.;
6380: 3b 3b 20 09 3b 3b 0a 3b 3b 3b 20 09 28 6d 61 70 ;; .;;.;;; .(map
6390: 20 3b 3b 20 0a 3b 3b 3b 20 09 20 28 6c 61 6d 62 ;; .;;; . (lamb
63a0: 64 61 20 28 71 75 65 75 65 2d 73 79 6d 29 0a 3b da (queue-sym).;
63b0: 3b 3b 20 09 20 20 20 3b 3b 20 28 70 72 69 6e 74 ;; . ;; (print
63c0: 20 22 70 72 6f 63 65 73 73 69 6e 67 20 71 75 65 "processing que
63d0: 75 65 20 22 20 71 75 65 75 65 2d 73 79 6d 29 0a ue " queue-sym).
63e0: 3b 3b 3b 20 09 20 20 20 28 6c 65 74 2a 20 28 28 ;;; . (let* ((
63f0: 71 75 65 75 65 20 28 71 75 65 75 65 2d 73 79 6d queue (queue-sym
6400: 2d 3e 71 75 65 75 65 20 71 75 65 75 65 2d 73 79 ->queue queue-sy
6410: 6d 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 28 m))).;;; . (
6420: 69 66 20 28 6e 6f 74 20 28 71 75 65 75 65 2d 65 if (not (queue-e
6430: 6d 70 74 79 3f 20 71 75 65 75 65 29 29 0a 3b 3b mpty? queue)).;;
6440: 3b 20 09 09 20 28 6c 65 74 20 28 28 72 65 73 70 ; .. (let ((resp
6450: 6f 6e 73 65 73 0a 3b 3b 3b 20 09 09 09 28 73 71 onses.;;; ...(sq
6460: 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 61 6e 73 lite3:with-trans
6470: 61 63 74 69 6f 6e 20 3b 3b 20 74 6f 64 6f 20 2d action ;; todo -
6480: 20 63 61 74 63 68 20 65 78 63 65 70 74 69 6f 6e catch exception
6490: 73 2e 2e 2e 0a 3b 3b 3b 20 09 09 09 20 64 62 68 s....;;; ... dbh
64a0: 0a 3b 3b 3b 20 09 09 09 20 28 6c 61 6d 62 64 61 .;;; ... (lambda
64b0: 20 28 29 0a 3b 3b 3b 20 09 09 09 20 20 20 28 6c ().;;; ... (l
64c0: 65 74 2a 20 28 28 72 65 73 20 28 64 6f 71 75 65 et* ((res (doque
64d0: 75 65 20 61 63 66 67 20 71 75 65 75 65 20 66 6e ue acfg queue fn
64e0: 61 6d 65 20 64 62 64 61 74 20 64 62 68 29 29 29 ame dbdat dbh)))
64f0: 20 3b 3b 20 74 68 69 73 20 64 6f 65 73 20 74 68 ;; this does th
6500: 65 20 77 6f 72 6b 21 0a 3b 3b 3b 20 09 09 09 20 e work!.;;; ...
6510: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 ;; (print "r
6520: 65 73 3d 22 20 72 65 73 29 0a 3b 3b 3b 20 09 09 es=" res).;;; ..
6530: 09 20 20 20 20 20 28 6d 61 74 63 68 20 72 65 73 . (match res
6540: 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 28 28 .;;; ... ((
6550: 63 6f 75 6e 74 20 64 65 6c 74 61 20 72 65 73 70 count delta resp
6560: 6f 6e 73 65 73 29 0a 3b 3b 3b 20 09 09 09 20 20 onses).;;; ...
6570: 20 20 20 20 20 28 75 70 64 61 74 65 2d 73 74 61 (update-sta
6580: 74 73 20 61 63 66 67 20 66 6e 61 6d 65 20 71 75 ts acfg fname qu
6590: 65 75 65 2d 73 79 6d 20 64 65 6c 74 61 20 63 6f eue-sym delta co
65a0: 75 6e 74 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 unt).;;; ...
65b0: 20 20 20 28 73 64 62 67 3e 20 22 70 72 6f 63 65 (sdbg> "proce
65c0: 73 73 2d 64 62 2d 71 75 65 72 69 65 73 22 20 22 ss-db-queries" "
65d0: 73 71 6c 69 74 65 33 2d 74 72 61 6e 73 61 63 74 sqlite3-transact
65e0: 69 6f 6e 22 20 70 72 6f 63 65 73 73 2d 64 62 2d ion" process-db-
65f0: 71 75 65 72 69 65 73 2d 73 74 61 72 74 2d 74 69 queries-start-ti
6600: 6d 65 20 23 66 20 23 66 29 0a 3b 3b 3b 20 09 09 me #f #f).;;; ..
6610: 09 20 20 20 20 20 20 20 72 65 73 70 6f 6e 73 65 . response
6620: 73 29 20 3b 3b 20 72 65 74 75 72 6e 20 72 65 73 s) ;; return res
6630: 70 6f 6e 73 65 73 0a 3b 3b 3b 20 09 09 09 20 20 ponses.;;; ...
6640: 20 20 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 09 (else.;;; ..
6650: 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 . (print "
6660: 45 52 52 4f 52 3a 20 62 61 64 20 72 65 74 75 72 ERROR: bad retur
6670: 6e 20 64 61 74 61 20 66 72 6f 6d 20 64 6f 71 75 n data from doqu
6680: 65 75 65 20 22 20 72 65 73 29 29 29 0a 3b 3b 3b eue " res))).;;;
6690: 20 09 09 09 20 20 20 20 20 29 29 29 29 29 0a 3b ... ))))).;
66a0: 3b 3b 20 09 09 20 20 20 3b 3b 20 68 61 76 69 6e ;; .. ;; havin
66b0: 67 20 63 6f 6d 70 6c 65 74 65 64 20 74 68 65 20 g completed the
66c0: 74 72 61 6e 73 61 63 74 69 6f 6e 2c 20 73 65 6e transaction, sen
66d0: 64 20 74 68 65 20 72 65 73 70 6f 6e 73 65 73 2e d the responses.
66e0: 0a 3b 3b 3b 20 09 09 20 20 20 3b 3b 20 28 70 72 .;;; .. ;; (pr
66f0: 69 6e 74 20 22 49 4e 46 4f 3a 20 73 65 6e 64 69 int "INFO: sendi
6700: 6e 67 20 22 20 28 6c 65 6e 67 74 68 20 72 65 73 ng " (length res
6710: 70 6f 6e 73 65 73 29 20 22 20 72 65 73 70 6f 6e ponses) " respon
6720: 73 65 73 2e 22 29 0a 3b 3b 3b 20 09 09 20 20 20 ses.").;;; ..
6730: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 65 73 70 (let loop ((resp
6740: 6f 6e 73 65 73 2d 6c 65 66 74 20 72 65 73 70 6f onses-left respo
6750: 6e 73 65 73 29 29 0a 3b 3b 3b 20 09 09 20 20 20 nses)).;;; ..
6760: 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 09 09 20 20 (cond.;;; ..
6770: 20 20 20 20 28 28 6e 75 6c 6c 3f 20 72 65 73 70 ((null? resp
6780: 6f 6e 73 65 73 2d 6c 65 66 74 29 20 20 23 74 29 onses-left) #t)
6790: 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 28 65 6c .;;; .. (el
67a0: 73 65 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 se.;;; ..
67b0: 28 6c 65 74 2a 20 28 28 77 69 74 65 6d 20 20 20 (let* ((witem
67c0: 20 28 63 61 72 20 72 65 73 70 6f 6e 73 65 73 2d (car responses-
67d0: 6c 65 66 74 29 29 0a 3b 3b 3b 20 09 09 09 20 20 left)).;;; ...
67e0: 20 20 20 20 28 72 65 73 70 6f 6e 73 65 20 28 63 (response (c
67f0: 64 72 20 72 65 73 70 6f 6e 73 65 73 2d 6c 65 66 dr responses-lef
6800: 74 29 29 29 20 20 0a 3b 3b 3b 20 09 09 09 20 28 t))) .;;; ... (
6810: 63 61 6c 6c 2d 64 65 6c 69 76 65 72 2d 72 65 73 call-deliver-res
6820: 70 6f 6e 73 65 20 61 63 66 67 20 28 77 69 74 65 ponse acfg (wite
6830: 6d 2d 72 69 70 61 64 64 72 20 77 69 74 65 6d 29 m-ripaddr witem)
6840: 28 77 69 74 65 6d 2d 72 70 6f 72 74 20 77 69 74 (witem-rport wit
6850: 65 6d 29 0a 3b 3b 3b 20 09 09 09 09 09 09 28 77 em).;;; ......(w
6860: 69 74 65 6d 2d 63 6f 6f 6b 69 65 20 77 69 74 65 item-cookie wite
6870: 6d 29 28 77 69 74 65 6d 2d 72 65 73 75 6c 74 20 m)(witem-result
6880: 77 69 74 65 6d 29 29 29 0a 3b 3b 3b 20 09 09 20 witem))).;;; ..
6890: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 64 72 (loop (cdr
68a0: 20 72 65 73 70 6f 6e 73 65 73 2d 6c 65 66 74 29 responses-left)
68b0: 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 29 29 29 ))))).;;; .. )))
68c0: 0a 3b 3b 3b 20 09 20 27 28 77 71 75 65 75 65 20 .;;; . '(wqueue
68d0: 72 77 71 75 65 75 65 20 72 71 75 65 75 65 29 29 rwqueue rqueue))
68e0: 0a 3b 3b 3b 20 09 0a 3b 3b 3b 20 09 3b 3b 20 68 .;;; ..;;; .;; h
68f0: 61 6e 64 6c 65 20 6d 69 73 63 20 71 75 65 75 65 andle misc queue
6900: 0a 3b 3b 3b 20 09 3b 3b 0a 3b 3b 3b 20 09 3b 3b .;;; .;;.;;; .;;
6910: 20 28 70 72 69 6e 74 20 22 70 72 6f 63 65 73 73 (print "process
6920: 69 6e 67 20 6d 69 73 63 20 71 75 65 75 65 22 29 ing misc queue")
6930: 0a 3b 3b 3b 20 09 28 6c 65 74 20 28 28 71 75 65 .;;; .(let ((que
6940: 75 65 20 28 71 75 65 75 65 2d 73 79 6d 2d 3e 71 ue (queue-sym->q
6950: 75 65 75 65 20 27 6d 69 73 63 29 29 29 0a 3b 3b ueue 'misc))).;;
6960: 3b 20 09 20 20 28 64 6f 71 75 65 75 65 20 61 63 ; . (doqueue ac
6970: 66 67 20 71 75 65 75 65 20 66 6e 61 6d 65 20 64 fg queue fname d
6980: 62 64 61 74 20 64 62 68 29 29 0a 3b 3b 3b 20 09 bdat dbh)).;;; .
6990: 3b 3b 20 2e 2e 2e 2e 0a 3b 3b 3b 20 09 28 73 61 ;; .....;;; .(sa
69a0: 76 65 2d 64 62 68 20 61 63 66 67 20 66 6e 61 6d ve-dbh acfg fnam
69b0: 65 20 64 62 64 61 74 29 0a 3b 3b 3b 20 09 23 74 e dbdat).;;; .#t
69c0: 20 3b 3b 20 6a 75 73 74 20 74 6f 20 6c 65 74 20 ;; just to let
69d0: 74 68 65 20 74 65 73 74 73 20 6b 6e 6f 77 20 77 the tests know w
69e0: 65 20 67 6f 74 20 68 65 72 65 0a 3b 3b 3b 20 09 e got here.;;; .
69f0: 29 0a 3b 3b 3b 20 20 20 20 20 20 20 23 66 20 3b ).;;; #f ;
6a00: 3b 20 6e 6f 74 68 69 6e 67 20 70 72 6f 63 65 73 ; nothing proces
6a10: 73 65 64 0a 3b 3b 3b 20 20 20 20 20 20 20 29 29 sed.;;; ))
6a20: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 72 75 6e .;;; .;;; ;; run
6a30: 20 61 6c 6c 20 71 75 65 75 65 73 20 69 6e 20 70 all queues in p
6a40: 61 72 61 6c 6c 65 6c 20 70 65 72 20 64 62 20 62 arallel per db b
6a50: 75 74 20 73 65 71 75 65 6e 74 69 61 6c 6c 79 20 ut sequentially
6a60: 70 65 72 20 71 75 65 75 65 20 66 6f 72 20 74 68 per queue for th
6a70: 61 74 20 64 62 2e 0a 3b 3b 3b 20 3b 3b 20 20 2d at db..;;; ;; -
6a80: 20 70 72 6f 63 65 73 73 20 74 68 65 20 71 75 65 process the que
6a90: 75 65 73 20 65 76 65 72 79 20 35 30 30 20 6f 72 ues every 500 or
6aa0: 20 73 6f 20 6d 73 0a 3b 3b 3b 20 3b 3b 20 20 2d so ms.;;; ;; -
6ab0: 20 61 6c 6c 6f 77 20 66 6f 72 20 6c 6f 6e 67 20 allow for long
6ac0: 72 75 6e 6e 69 6e 67 20 71 75 65 72 69 65 73 20 running queries
6ad0: 74 6f 20 63 6f 6e 74 69 6e 75 65 20 62 75 74 20 to continue but
6ae0: 61 6c 6c 20 6f 74 68 65 72 20 61 63 74 69 76 69 all other activi
6af0: 74 69 65 73 20 66 6f 72 20 74 68 61 74 0a 3b 3b ties for that.;;
6b00: 3b 20 3b 3b 20 20 20 20 64 62 20 77 69 6c 6c 20 ; ;; db will
6b10: 62 65 20 62 6c 6f 63 6b 65 64 2e 0a 3b 3b 3b 20 be blocked..;;;
6b20: 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;.;;; (define (
6b30: 77 6f 72 6b 2d 71 75 65 75 65 2d 70 72 6f 63 65 work-queue-proce
6b40: 73 73 6f 72 20 61 63 66 67 29 0a 3b 3b 3b 20 20 ssor acfg).;;;
6b50: 20 28 6c 65 74 2a 20 28 28 74 68 72 65 61 64 73 (let* ((threads
6b60: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
6b70: 65 29 29 29 20 3b 3b 20 66 6e 61 6d 65 20 3d 3e e))) ;; fname =>
6b80: 20 74 68 72 65 61 64 0a 3b 3b 3b 20 20 20 20 20 thread.;;;
6b90: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 66 6e 61 6d (let loop ((fnam
6ba0: 65 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 es (hash-ta
6bb0: 62 6c 65 2d 6b 65 79 73 20 28 61 72 65 61 2d 77 ble-keys (area-w
6bc0: 71 75 65 75 65 73 20 61 63 66 67 29 29 29 0a 3b queues acfg))).;
6bd0: 3b 3b 20 09 20 20 20 20 20 20 20 28 74 61 72 67 ;; . (targ
6be0: 65 74 2d 74 69 6d 65 20 28 2b 20 28 63 75 72 72 et-time (+ (curr
6bf0: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
6c00: 29 20 35 30 29 29 29 0a 3b 3b 3b 20 20 20 20 20 ) 50))).;;;
6c10: 20 20 3b 3b 28 69 66 20 28 6e 6f 74 20 28 6e 75 ;;(if (not (nu
6c20: 6c 6c 3f 20 66 6e 61 6d 65 73 29 29 28 70 72 69 ll? fnames))(pri
6c30: 6e 74 20 22 50 72 6f 63 65 73 73 69 6e 67 20 66 nt "Processing f
6c40: 6f 72 20 74 68 65 73 65 20 64 61 74 61 62 61 73 or these databas
6c50: 65 73 3a 20 22 20 66 6e 61 6d 65 73 29 29 0a 3b es: " fnames)).;
6c60: 3b 3b 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 ;; (for-ea
6c70: 63 68 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 6c ch.;;; (l
6c80: 61 6d 62 64 61 20 28 66 6e 61 6d 65 29 0a 3b 3b ambda (fname).;;
6c90: 3b 20 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 70 ; . ;; (print "p
6ca0: 72 6f 63 65 73 73 69 6e 67 20 66 6f 72 20 22 20 rocessing for "
6cb0: 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 20 3b 3b 28 fname).;;; . ;;(
6cc0: 70 72 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 69 process-db-queri
6cd0: 65 73 20 61 63 66 67 20 66 6e 61 6d 65 29 29 0a es acfg fname)).
6ce0: 3b 3b 3b 20 09 20 28 6c 65 74 20 28 28 74 68 20 ;;; . (let ((th
6cf0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
6d00: 64 65 66 61 75 6c 74 20 74 68 72 65 61 64 73 20 default threads
6d10: 66 6e 61 6d 65 20 23 66 29 29 29 0a 3b 3b 3b 20 fname #f))).;;;
6d20: 09 20 20 20 28 69 66 20 28 61 6e 64 20 74 68 20 . (if (and th
6d30: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 74 68 (not (member (th
6d40: 72 65 61 64 2d 73 74 61 74 65 20 74 68 29 20 27 read-state th) '
6d50: 28 64 65 61 64 20 74 65 72 6d 69 6e 61 74 65 64 (dead terminated
6d60: 29 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 )))).;;; .
6d70: 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 28 (begin.;;; .. (
6d80: 70 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 print "WARNING:
6d90: 77 6f 72 6b 65 72 20 74 68 72 65 61 64 20 66 6f worker thread fo
6da0: 72 20 22 20 66 6e 61 6d 65 20 22 20 69 73 20 74 r " fname " is t
6db0: 61 6b 69 6e 67 20 61 20 6c 6f 6e 67 20 74 69 6d aking a long tim
6dc0: 65 2e 22 29 0a 3b 3b 3b 20 09 09 20 28 70 72 69 e.").;;; .. (pri
6dd0: 6e 74 20 22 54 68 72 65 61 64 20 69 73 20 69 6e nt "Thread is in
6de0: 20 73 74 61 74 65 20 22 20 28 74 68 72 65 61 64 state " (thread
6df0: 2d 73 74 61 74 65 20 74 68 29 29 29 0a 3b 3b 3b -state th))).;;;
6e00: 20 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 . (let ((
6e10: 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th1 (make-thread
6e20: 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 (lambda ().;;;
6e30: 09 09 09 09 09 20 3b 3b 20 28 63 61 74 63 68 2d ..... ;; (catch-
6e40: 61 6e 64 2d 64 75 6d 70 0a 3b 3b 3b 20 09 09 09 and-dump.;;; ...
6e50: 09 09 20 3b 3b 20 20 28 6c 61 6d 62 64 61 20 28 .. ;; (lambda (
6e60: 29 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 3b ).;;; ..... ;
6e70: 3b 20 28 70 72 69 6e 74 20 22 50 72 6f 63 65 73 ; (print "Proces
6e80: 73 20 71 75 65 72 69 65 73 20 66 6f 72 20 22 20 s queries for "
6e90: 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 09 09 09 09 fname).;;; .....
6ea0: 20 20 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 (let ((start
6eb0: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d -time (current-m
6ec0: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b illiseconds))).;
6ed0: 3b 3b 20 09 09 09 09 09 20 20 20 20 20 20 28 70 ;; ..... (p
6ee0: 72 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 69 65 rocess-db-querie
6ef0: 73 20 61 63 66 67 20 66 6e 61 6d 65 29 0a 3b 3b s acfg fname).;;
6f00: 3b 20 09 09 09 09 09 20 20 20 20 20 20 3b 3b 20 ; ..... ;;
6f10: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
6f20: 2e 30 31 29 20 3b 3b 20 6e 65 65 64 20 74 68 65 .01) ;; need the
6f30: 20 74 68 72 65 61 64 20 74 6f 20 74 61 6b 65 20 thread to take
6f40: 61 74 20 6c 65 61 73 74 20 73 6f 6d 65 20 74 69 at least some ti
6f50: 6d 65 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 me.;;; .....
6f60: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 (hash-table-de
6f70: 6c 65 74 65 21 20 74 68 72 65 61 64 73 20 66 6e lete! threads fn
6f80: 61 6d 65 29 29 20 3b 3b 20 6e 6f 20 6d 75 74 65 ame)) ;; no mute
6f90: 78 65 73 3f 0a 3b 3b 3b 20 09 09 09 09 09 20 20 xes?.;;; .....
6fa0: 20 20 66 6e 61 6d 65 29 0a 3b 3b 3b 20 09 09 09 fname).;;; ...
6fb0: 09 09 20 20 22 74 68 31 22 29 29 29 20 3b 3b 20 .. "th1"))) ;;
6fc0: 29 29 0a 3b 3b 3b 20 09 09 20 28 68 61 73 68 2d )).;;; .. (hash-
6fd0: 74 61 62 6c 65 2d 73 65 74 21 20 74 68 72 65 61 table-set! threa
6fe0: 64 73 20 66 6e 61 6d 65 20 74 68 31 29 0a 3b 3b ds fname th1).;;
6ff0: 3b 20 09 09 20 28 74 68 72 65 61 64 2d 73 74 61 ; .. (thread-sta
7000: 72 74 21 20 74 68 31 29 29 29 29 29 0a 3b 3b 3b rt! th1))))).;;;
7010: 20 20 20 20 20 20 20 20 66 6e 61 6d 65 73 29 0a fnames).
7020: 3b 3b 3b 20 20 20 20 20 20 20 3b 3b 20 28 74 68 ;;; ;; (th
7030: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 read-sleep! 0.1)
7040: 20 3b 3b 20 67 69 76 65 20 74 68 65 20 74 68 72 ;; give the thr
7050: 65 61 64 73 20 73 6f 6d 65 20 74 69 6d 65 20 74 eads some time t
7060: 6f 20 70 72 6f 63 65 73 73 20 72 65 71 75 65 73 o process reques
7070: 74 73 0a 3b 3b 3b 20 20 20 20 20 20 20 3b 3b 20 ts.;;; ;;
7080: 62 75 72 6e 20 74 69 6d 65 20 75 6e 74 69 6c 20 burn time until
7090: 34 30 30 6d 73 20 69 73 20 75 70 0a 3b 3b 3b 20 400ms is up.;;;
70a0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 6f 77 (let ((now
70b0: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d -time (current-m
70c0: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b illiseconds))).;
70d0: 3b 3b 20 09 28 69 66 20 28 3c 20 6e 6f 77 2d 74 ;; .(if (< now-t
70e0: 69 6d 65 20 74 61 72 67 65 74 2d 74 69 6d 65 29 ime target-time)
70f0: 0a 3b 3b 3b 20 09 20 20 20 20 28 6c 65 74 20 28 .;;; . (let (
7100: 28 64 65 6c 74 61 20 28 2d 20 74 61 72 67 65 74 (delta (- target
7110: 2d 74 69 6d 65 20 6e 6f 77 2d 74 69 6d 65 29 29 -time now-time))
7120: 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 74 68 ).;;; . (th
7130: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 64 read-sleep! (/ d
7140: 65 6c 74 61 20 31 30 30 30 29 29 29 29 29 0a 3b elta 1000))))).;
7150: 3b 3b 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ;; (loop (
7160: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
7170: 28 61 72 65 61 2d 77 71 75 65 75 65 73 20 61 63 (area-wqueues ac
7180: 66 67 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 2b fg)).;;; . (+
7190: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
71a0: 65 63 6f 6e 64 73 29 20 35 30 29 29 29 29 29 0a econds) 50))))).
71b0: 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d ;;; .;;; ;;=====
71c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
71d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
71e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
71f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7200: 3d 0a 3b 3b 3b 20 3b 3b 20 53 20 54 20 41 20 54 =.;;; ;; S T A T
7210: 20 53 20 20 20 47 20 41 20 54 20 48 20 45 20 52 S G A T H E R
7220: 20 49 20 4e 20 47 0a 3b 3b 3b 20 3b 3b 3d 3d 3d I N G.;;; ;;===
7230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7270: 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 ===.;;; .;;; (de
7280: 66 73 74 72 75 63 74 20 73 74 61 74 0a 3b 3b 3b fstruct stat.;;;
7290: 20 20 20 28 71 63 6f 75 6e 74 2d 61 76 67 20 20 (qcount-avg
72a0: 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
72b0: 20 20 20 20 3b 3b 20 63 6f 61 72 73 65 20 72 75 ;; coarse ru
72c0: 6e 6e 69 6e 67 20 61 76 65 72 61 67 65 0a 3b 3b nning average.;;
72d0: 3b 20 20 20 28 71 74 69 6d 65 2d 61 76 67 20 20 ; (qtime-avg
72e0: 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
72f0: 20 20 20 20 20 3b 3b 20 63 6f 61 72 73 65 20 72 ;; coarse r
7300: 75 6e 6e 69 6e 67 20 61 76 65 72 61 67 65 0a 3b unning average.;
7310: 3b 3b 20 20 20 28 71 63 6f 75 6e 74 20 20 20 20 ;; (qcount
7320: 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 0)
7330: 20 20 20 20 20 20 3b 3b 20 74 6f 74 61 6c 0a 3b ;; total.;
7340: 3b 3b 20 20 20 28 71 74 69 6d 65 20 20 20 20 20 ;; (qtime
7350: 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 0)
7360: 20 20 20 20 20 20 3b 3b 20 74 6f 74 61 6c 0a 3b ;; total.;
7370: 3b 3b 20 20 20 28 6c 61 73 74 2d 71 63 6f 75 6e ;; (last-qcoun
7380: 74 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 t 0)
7390: 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 0a 3b ;; last .;
73a0: 3b 3b 20 20 20 28 6c 61 73 74 2d 71 74 69 6d 65 ;; (last-qtime
73b0: 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 0)
73c0: 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 0a 3b 3b ;; last.;;
73d0: 3b 20 20 20 28 64 62 73 20 20 20 20 20 20 20 20 ; (dbs
73e0: 27 28 29 29 20 20 20 20 20 20 20 20 20 20 20 20 '())
73f0: 20 20 20 20 20 3b 3b 20 6c 69 73 74 20 6f 66 20 ;; list of
7400: 64 62 20 66 69 6c 65 73 20 68 61 6e 64 6c 65 64 db files handled
7410: 20 62 79 20 74 68 69 73 20 6e 6f 64 65 0a 3b 3b by this node.;;
7420: 3b 20 20 20 28 77 68 65 6e 20 20 20 20 20 20 20 ; (when
7430: 20 30 29 29 20 20 20 20 20 20 20 20 20 20 20 20 0))
7440: 20 20 20 20 20 3b 3b 20 77 68 65 6e 20 74 68 65 ;; when the
7450: 20 6c 61 73 74 20 71 75 65 72 79 20 68 61 70 70 last query happ
7460: 65 6e 65 64 20 2d 20 73 65 63 6f 6e 64 73 0a 3b ened - seconds.;
7470: 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 ;; .;;; .;;; (de
7480: 66 69 6e 65 20 28 75 70 64 61 74 65 2d 73 74 61 fine (update-sta
7490: 74 73 20 61 63 66 67 20 66 6e 61 6d 65 20 62 75 ts acfg fname bu
74a0: 63 6b 65 74 20 64 75 72 61 74 69 6f 6e 20 6e 75 cket duration nu
74b0: 6d 71 75 65 72 69 65 73 29 0a 3b 3b 3b 20 20 20 mqueries).;;;
74c0: 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 66 6e (let* ((key fn
74d0: 61 6d 65 29 20 3b 3b 20 66 6f 72 20 6e 6f 77 20 ame) ;; for now
74e0: 64 6f 20 6e 6f 74 20 75 73 65 20 62 75 63 6b 65 do not use bucke
74f0: 74 2e 20 57 61 73 3a 20 28 63 6f 6e 63 20 66 6e t. Was: (conc fn
7500: 61 6d 65 20 22 2d 22 20 62 75 63 6b 65 74 29 29 ame "-" bucket))
7510: 20 3b 3b 20 6c 61 7a 79 20 62 75 74 20 67 6f 6f ;; lazy but goo
7520: 64 20 65 6e 6f 75 67 68 0a 3b 3b 3b 20 09 20 28 d enough.;;; . (
7530: 73 74 61 74 73 20 28 6f 72 20 28 68 61 73 68 2d stats (or (hash-
7540: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
7550: 74 20 28 61 72 65 61 2d 73 74 61 74 73 20 61 63 t (area-stats ac
7560: 66 67 29 20 6b 65 79 20 23 66 29 0a 3b 3b 3b 20 fg) key #f).;;;
7570: 09 09 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 .. (let ((new
7580: 73 74 61 74 73 20 28 6d 61 6b 65 2d 73 74 61 74 stats (make-stat
7590: 29 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 ))).;;; ..
75a0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
75b0: 20 28 61 72 65 61 2d 73 74 61 74 73 20 61 63 66 (area-stats acf
75c0: 67 29 20 6b 65 79 20 6e 65 77 73 74 61 74 73 29 g) key newstats)
75d0: 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 6e 65 77 .;;; .. new
75e0: 73 74 61 74 73 29 29 29 29 0a 3b 3b 3b 20 20 20 stats)))).;;;
75f0: 20 20 3b 3b 20 77 68 65 6e 20 74 68 65 20 6c 61 ;; when the la
7600: 73 74 20 71 75 65 72 79 20 68 61 70 70 65 6e 64 st query happend
7610: 65 64 20 28 75 73 65 64 20 74 6f 20 72 65 6d 6f ed (used to remo
7620: 76 65 20 74 68 65 20 66 6e 61 6d 65 20 66 72 6f ve the fname fro
7630: 6d 20 74 68 65 20 61 63 74 69 76 65 20 6c 69 73 m the active lis
7640: 74 29 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 t).;;; (stat
7650: 2d 77 68 65 6e 2d 73 65 74 21 20 73 74 61 74 73 -when-set! stats
7660: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
7670: 73 29 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 6c s)).;;; ;; l
7680: 61 73 74 20 76 61 6c 75 65 73 0a 3b 3b 3b 20 20 ast values.;;;
7690: 20 20 20 28 73 74 61 74 2d 6c 61 73 74 2d 71 63 (stat-last-qc
76a0: 6f 75 6e 74 2d 73 65 74 21 20 73 74 61 74 73 20 ount-set! stats
76b0: 6e 75 6d 71 75 65 72 69 65 73 29 0a 3b 3b 3b 20 numqueries).;;;
76c0: 20 20 20 20 28 73 74 61 74 2d 6c 61 73 74 2d 71 (stat-last-q
76d0: 74 69 6d 65 2d 73 65 74 21 20 20 73 74 61 74 73 time-set! stats
76e0: 20 64 75 72 61 74 69 6f 6e 29 0a 3b 3b 3b 20 20 duration).;;;
76f0: 20 20 20 3b 3b 20 74 6f 74 61 6c 20 6f 76 65 72 ;; total over
7700: 20 70 72 6f 63 65 73 73 20 6c 69 66 65 74 69 6d process lifetim
7710: 65 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 2d e.;;; (stat-
7720: 71 63 6f 75 6e 74 2d 73 65 74 21 20 73 74 61 74 qcount-set! stat
7730: 73 20 28 2b 20 28 73 74 61 74 2d 71 63 6f 75 6e s (+ (stat-qcoun
7740: 74 20 73 74 61 74 73 29 20 6e 75 6d 71 75 65 72 t stats) numquer
7750: 69 65 73 29 29 0a 3b 3b 3b 20 20 20 20 20 28 73 ies)).;;; (s
7760: 74 61 74 2d 71 74 69 6d 65 2d 73 65 74 21 20 20 tat-qtime-set!
7770: 73 74 61 74 73 20 28 2b 20 28 73 74 61 74 2d 71 stats (+ (stat-q
7780: 74 69 6d 65 20 20 73 74 61 74 73 29 20 64 75 72 time stats) dur
7790: 61 74 69 6f 6e 29 29 0a 3b 3b 3b 20 20 20 20 20 ation)).;;;
77a0: 3b 3b 20 63 6f 61 72 73 65 20 61 76 65 72 61 67 ;; coarse averag
77b0: 65 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 74 2d e.;;; (stat-
77c0: 71 63 6f 75 6e 74 2d 61 76 67 2d 73 65 74 21 20 qcount-avg-set!
77d0: 73 74 61 74 73 20 28 2f 20 28 2b 20 28 73 74 61 stats (/ (+ (sta
77e0: 74 2d 71 63 6f 75 6e 74 2d 61 76 67 20 73 74 61 t-qcount-avg sta
77f0: 74 73 29 20 6e 75 6d 71 75 65 72 69 65 73 29 20 ts) numqueries)
7800: 32 29 29 0a 3b 3b 3b 20 20 20 20 20 28 73 74 61 2)).;;; (sta
7810: 74 2d 71 74 69 6d 65 2d 61 76 67 2d 73 65 74 21 t-qtime-avg-set!
7820: 20 20 73 74 61 74 73 20 28 2f 20 28 2b 20 28 73 stats (/ (+ (s
7830: 74 61 74 2d 71 74 69 6d 65 2d 61 76 67 20 20 73 tat-qtime-avg s
7840: 74 61 74 73 29 20 64 75 72 61 74 69 6f 6e 29 20 tats) duration)
7850: 20 20 32 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 2)).;;; .;;;
7860: 20 20 20 3b 3b 20 68 65 72 65 20 69 73 20 77 68 ;; here is wh
7870: 65 72 65 20 77 65 20 61 64 64 20 74 68 65 20 73 ere we add the s
7880: 74 61 74 73 20 66 6f 72 20 61 20 67 69 76 65 6e tats for a given
7890: 20 64 62 66 69 6c 65 0a 3b 3b 3b 20 20 20 20 20 dbfile.;;;
78a0: 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 (if (not (member
78b0: 20 66 6e 61 6d 65 20 28 73 74 61 74 2d 64 62 73 fname (stat-dbs
78c0: 20 73 74 61 74 73 29 29 29 0a 3b 3b 3b 20 09 28 stats))).;;; .(
78d0: 73 74 61 74 2d 64 62 73 2d 73 65 74 21 20 73 74 stat-dbs-set! st
78e0: 61 74 73 20 28 63 6f 6e 73 20 66 6e 61 6d 65 20 ats (cons fname
78f0: 28 73 74 61 74 2d 64 62 73 20 73 74 61 74 73 29 (stat-dbs stats)
7900: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 ))).;;; .;;;
7910: 20 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d )).;;; .;;; ;;=
7920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7960: 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 53 20 45 =====.;;; ;; S E
7970: 20 52 20 56 20 45 20 52 20 20 20 53 20 54 20 55 R V E R S T U
7980: 20 46 20 46 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d F F .;;; ;;====
7990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79d0: 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 74 ==.;;; .;;; ;; t
79e0: 68 69 73 20 64 6f 65 73 20 4e 4f 54 20 72 65 74 his does NOT ret
79f0: 75 72 6e 21 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 urn!.;;; ;;.;;;
7a00: 28 64 65 66 69 6e 65 20 28 66 69 6e 64 2d 66 72 (define (find-fr
7a10: 65 65 2d 70 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e ee-port-and-open
7a20: 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 28 6c 65 acfg).;;; (le
7a30: 74 20 28 28 70 6f 72 74 20 28 6f 72 20 28 61 72 t ((port (or (ar
7a40: 65 61 2d 70 6f 72 74 20 61 63 66 67 29 20 33 32 ea-port acfg) 32
7a50: 30 30 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 68 00))).;;; (h
7a60: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
7a70: 0a 3b 3b 3b 20 09 65 78 6e 0a 3b 3b 3b 20 09 28 .;;; .exn.;;; .(
7a80: 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 28 70 72 begin.;;; . (pr
7a90: 69 6e 74 20 22 49 4e 46 4f 3a 20 63 61 6e 6e 6f int "INFO: canno
7aa0: 74 20 62 69 6e 64 20 74 6f 20 70 6f 72 74 20 22 t bind to port "
7ab0: 20 28 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 (rpc:default-se
7ac0: 72 76 65 72 2d 70 6f 72 74 29 20 22 2c 20 74 72 rver-port) ", tr
7ad0: 79 69 6e 67 20 6e 65 78 74 20 70 6f 72 74 22 29 ying next port")
7ae0: 0a 3b 3b 3b 20 09 20 20 28 61 72 65 61 2d 70 6f .;;; . (area-po
7af0: 72 74 2d 73 65 74 21 20 61 63 66 67 20 28 2b 20 rt-set! acfg (+
7b00: 70 6f 72 74 20 31 29 29 0a 3b 3b 3b 20 09 20 20 port 1)).;;; .
7b10: 28 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d (find-free-port-
7b20: 61 6e 64 2d 6f 70 65 6e 20 61 63 66 67 29 29 0a and-open acfg)).
7b30: 3b 3b 3b 20 20 20 20 20 20 20 28 72 70 63 3a 64 ;;; (rpc:d
7b40: 65 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f efault-server-po
7b50: 72 74 20 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 20 rt port).;;;
7b60: 20 20 20 28 61 72 65 61 2d 70 6f 72 74 2d 73 65 (area-port-se
7b70: 74 21 20 61 63 66 67 20 70 6f 72 74 29 0a 3b 3b t! acfg port).;;
7b80: 3b 20 20 20 20 20 20 20 28 74 63 70 2d 72 65 61 ; (tcp-rea
7b90: 64 2d 74 69 6d 65 6f 75 74 20 31 32 30 30 30 30 d-timeout 120000
7ba0: 29 0a 3b 3b 3b 20 20 20 20 20 20 20 3b 3b 20 28 ).;;; ;; (
7bb0: 28 72 70 63 3a 6d 61 6b 65 2d 73 65 72 76 65 72 (rpc:make-server
7bc0: 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 70 6f 72 (tcp-listen por
7bd0: 74 29 29 20 23 74 29 0a 3b 3b 3b 20 20 20 20 20 t)) #t).;;;
7be0: 20 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 28 72 (tcp-listen (r
7bf0: 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 65 pc:default-serve
7c00: 72 2d 70 6f 72 74 29 0a 3b 3b 3b 20 20 20 20 20 r-port).;;;
7c10: 20 20 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 )))).;;; .;;;
7c20: 3b 3b 20 72 65 67 69 73 74 65 72 20 74 68 69 73 ;; register this
7c30: 20 6e 6f 64 65 20 62 79 20 70 75 74 74 69 6e 67 node by putting
7c40: 20 61 20 70 61 63 6b 65 74 20 69 6e 74 6f 20 74 a packet into t
7c50: 68 65 20 70 6b 74 73 20 64 69 72 2e 0a 3b 3b 3b he pkts dir..;;;
7c60: 20 3b 3b 20 6c 6f 6f 6b 20 66 6f 72 20 6f 74 68 ;; look for oth
7c70: 65 72 20 73 65 72 76 65 72 73 0a 3b 3b 3b 20 3b er servers.;;; ;
7c80: 3b 20 63 6f 6e 74 61 63 74 20 6f 74 68 65 72 20 ; contact other
7c90: 73 65 72 76 65 72 73 20 61 6e 64 20 63 6f 6d 70 servers and comp
7ca0: 69 6c 65 20 6c 69 73 74 20 6f 66 20 73 65 72 76 ile list of serv
7cb0: 65 72 73 0a 3b 3b 3b 20 3b 3b 20 74 68 65 72 65 ers.;;; ;; there
7cc0: 20 61 72 65 20 74 77 6f 20 74 79 70 65 73 20 6f are two types o
7cd0: 66 20 73 65 72 76 65 72 0a 3b 3b 3b 20 3b 3b 20 f server.;;; ;;
7ce0: 20 20 20 20 6d 61 69 6e 20 73 65 72 76 65 72 73 main servers
7cf0: 20 2d 20 64 61 73 68 62 6f 61 72 64 73 2c 20 72 - dashboards, r
7d00: 75 6e 6e 65 72 73 20 61 6e 64 20 64 65 64 69 63 unners and dedic
7d10: 61 74 65 64 20 73 65 72 76 65 72 73 20 2d 20 6e ated servers - n
7d20: 65 65 64 20 70 6b 74 0a 3b 3b 3b 20 3b 3b 20 20 eed pkt.;;; ;;
7d30: 20 20 20 70 61 73 73 69 76 65 20 73 65 72 76 65 passive serve
7d40: 72 73 20 2d 20 74 65 73 74 20 65 78 65 63 75 74 rs - test execut
7d50: 65 72 73 2c 20 73 74 65 70 20 63 61 6c 6c 73 2c ers, step calls,
7d60: 20 6c 69 73 74 2d 72 75 6e 73 20 2d 20 6e 6f 20 list-runs - no
7d70: 70 6b 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 pkt.;;; ;;.;;; (
7d80: 64 65 66 69 6e 65 20 28 72 65 67 69 73 74 65 72 define (register
7d90: 2d 6e 6f 64 65 20 61 63 66 67 20 68 6f 73 74 69 -node acfg hosti
7da0: 70 20 70 6f 72 74 2d 6e 75 6d 29 0a 3b 3b 3b 20 p port-num).;;;
7db0: 20 20 3b 3b 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 ;;(mutex-lock!
7dc0: 20 28 61 72 65 61 2d 6d 75 74 65 78 20 61 63 66 (area-mutex acf
7dd0: 67 29 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 g)).;;; (let*
7de0: 28 28 73 65 72 76 65 72 2d 74 79 70 65 20 20 28 ((server-type (
7df0: 61 72 65 61 2d 73 65 72 76 65 72 2d 74 79 70 65 area-server-type
7e00: 20 61 63 66 67 29 29 20 3b 3b 20 61 75 74 6f 2c acfg)) ;; auto,
7e10: 20 6d 61 69 6e 2c 20 70 61 73 73 69 76 65 20 28 main, passive (
7e20: 6e 6f 20 70 6b 74 20 63 72 65 61 74 65 64 29 0a no pkt created).
7e30: 3b 3b 3b 20 09 20 28 62 65 73 74 2d 69 70 20 20 ;;; . (best-ip
7e40: 20 20 20 20 28 6f 72 20 68 6f 73 74 69 70 20 28 (or hostip (
7e50: 67 65 74 2d 6d 79 2d 62 65 73 74 2d 61 64 64 72 get-my-best-addr
7e60: 65 73 73 29 29 29 0a 3b 3b 3b 20 09 20 28 6d 74 ess))).;;; . (mt
7e70: 64 69 72 20 20 20 20 20 20 20 20 28 61 72 65 61 dir (area
7e80: 2d 64 62 64 69 72 20 61 63 66 67 29 29 0a 3b 3b -dbdir acfg)).;;
7e90: 3b 20 09 20 28 70 6b 74 64 69 72 20 20 20 20 20 ; . (pktdir
7ea0: 20 20 28 61 72 65 61 2d 70 6b 74 73 64 69 72 20 (area-pktsdir
7eb0: 61 63 66 67 29 29 29 20 3b 3b 20 63 6f 6e 63 20 acfg))) ;; conc
7ec0: 6d 74 64 69 72 20 22 2f 2e 73 65 72 76 65 72 2d mtdir "/.server-
7ed0: 70 6b 74 73 22 29 29 29 0a 3b 3b 3b 20 20 20 20 pkts"))).;;;
7ee0: 20 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 (print "Registe
7ef0: 72 69 6e 67 20 6e 6f 64 65 20 22 20 62 65 73 74 ring node " best
7f00: 2d 69 70 20 22 3a 22 20 70 6f 72 74 2d 6e 75 6d -ip ":" port-num
7f10: 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 28 6e ).;;; (if (n
7f20: 6f 74 20 6d 74 64 69 72 29 20 3b 3b 20 72 65 71 ot mtdir) ;; req
7f30: 75 69 72 65 20 61 20 68 6f 6d 65 20 66 6f 72 20 uire a home for
7f40: 74 68 69 73 20 6e 6f 64 65 20 74 6f 20 70 75 74 this node to put
7f50: 20 6f 72 20 66 69 6e 64 20 64 61 74 61 62 61 73 or find databas
7f60: 65 73 0a 3b 3b 3b 20 09 23 66 0a 3b 3b 3b 20 09 es.;;; .#f.;;; .
7f70: 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 28 69 (begin.;;; . (i
7f80: 66 20 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f f (not (directo
7f90: 72 79 3f 20 70 6b 74 64 69 72 29 29 28 63 72 65 ry? pktdir))(cre
7fa0: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 70 6b ate-directory pk
7fb0: 74 64 69 72 29 29 0a 3b 3b 3b 20 09 20 20 3b 3b tdir)).;;; . ;;
7fc0: 20 73 65 72 76 65 72 20 69 73 20 73 74 61 72 74 server is start
7fd0: 65 64 2c 20 6e 6f 77 20 63 72 65 61 74 65 20 70 ed, now create p
7fe0: 6b 74 20 69 66 20 6e 65 65 64 65 64 0a 3b 3b 3b kt if needed.;;;
7ff0: 20 09 20 20 28 70 72 69 6e 74 20 22 53 74 61 72 . (print "Star
8000: 74 69 6e 67 20 73 65 72 76 65 72 20 69 6e 20 22 ting server in "
8010: 20 73 65 72 76 65 72 2d 74 79 70 65 20 22 20 6d server-type " m
8020: 6f 64 65 20 77 69 74 68 20 70 6f 72 74 20 22 20 ode with port "
8030: 70 6f 72 74 2d 6e 75 6d 29 0a 3b 3b 3b 20 09 20 port-num).;;; .
8040: 20 28 69 66 20 28 6d 65 6d 62 65 72 20 73 65 72 (if (member ser
8050: 76 65 72 2d 74 79 70 65 20 27 28 61 75 74 6f 20 ver-type '(auto
8060: 6d 61 69 6e 29 29 20 3b 3b 20 54 4f 44 4f 3a 20 main)) ;; TODO:
8070: 69 66 20 61 75 74 6f 2c 20 63 6f 75 6e 74 20 6e if auto, count n
8080: 75 6d 62 65 72 20 6f 66 20 73 65 72 76 65 72 73 umber of servers
8090: 20 72 65 67 69 73 74 65 72 73 2c 20 69 66 20 3e registers, if >
80a0: 20 33 20 74 68 65 6e 20 64 6f 6e 27 74 20 70 75 3 then don't pu
80b0: 74 20 6f 75 74 20 61 20 70 6b 74 0a 3b 3b 3b 20 t out a pkt.;;;
80c0: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b . (begin.;;
80d0: 3b 20 09 09 28 61 72 65 61 2d 70 6b 74 69 64 2d ; ..(area-pktid-
80e0: 73 65 74 21 20 61 63 66 67 0a 3b 3b 3b 20 09 09 set! acfg.;;; ..
80f0: 09 09 20 28 77 72 69 74 65 2d 61 6c 69 73 74 2d .. (write-alist-
8100: 3e 70 6b 74 0a 3b 3b 3b 20 09 09 09 09 20 20 70 >pkt.;;; .... p
8110: 6b 74 64 69 72 20 0a 3b 3b 3b 20 09 09 09 09 20 ktdir .;;; ....
8120: 20 60 28 28 68 6f 73 74 6e 61 6d 65 20 2e 20 2c `((hostname . ,
8130: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
8140: 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 28 69 70 .;;; .... (ip
8150: 61 64 64 72 20 20 20 2e 20 2c 62 65 73 74 2d 69 addr . ,best-i
8160: 70 29 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 28 p).;;; .... (
8170: 70 6f 72 74 20 20 20 20 20 2e 20 2c 70 6f 72 74 port . ,port
8180: 2d 6e 75 6d 29 0a 3b 3b 3b 20 09 09 09 09 20 20 -num).;;; ....
8190: 20 20 28 70 69 64 20 20 20 20 20 20 2e 20 2c 28 (pid . ,(
81a0: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
81b0: 69 64 29 29 29 0a 3b 3b 3b 20 09 09 09 09 20 20 id))).;;; ....
81c0: 70 6b 74 73 70 65 63 3a 20 2a 70 6b 74 73 70 65 pktspec: *pktspe
81d0: 63 2a 0a 3b 3b 3b 20 09 09 09 09 20 20 70 74 79 c*.;;; .... pty
81e0: 70 65 3a 20 20 20 27 73 65 72 76 65 72 29 29 0a pe: 'server)).
81f0: 3b 3b 3b 20 09 09 28 61 72 65 61 2d 70 6b 74 66 ;;; ..(area-pktf
8200: 69 6c 65 2d 73 65 74 21 20 61 63 66 67 20 28 63 ile-set! acfg (c
8210: 6f 6e 63 20 70 6b 74 64 69 72 20 22 2f 22 20 28 onc pktdir "/" (
8220: 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 area-pktid acfg)
8230: 20 22 2e 70 6b 74 22 29 29 29 29 0a 3b 3b 3b 20 ".pkt")))).;;;
8240: 09 20 20 28 61 72 65 61 2d 70 6f 72 74 2d 73 65 . (area-port-se
8250: 74 21 20 20 20 20 61 63 66 67 20 70 6f 72 74 2d t! acfg port-
8260: 6e 75 6d 29 0a 3b 3b 3b 20 09 20 20 23 3b 28 6d num).;;; . #;(m
8270: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 28 61 72 utex-unlock! (ar
8280: 65 61 2d 6d 75 74 65 78 20 61 63 66 67 29 29 29 ea-mutex acfg)))
8290: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 ))).;;; .;;; (de
82a0: 66 69 6e 65 20 2a 63 6f 6f 6b 69 65 2d 73 65 71 fine *cookie-seq
82b0: 6e 75 6d 2a 20 30 29 0a 3b 3b 3b 20 28 64 65 66 num* 0).;;; (def
82c0: 69 6e 65 20 28 6d 61 6b 65 2d 63 6f 6f 6b 69 65 ine (make-cookie
82d0: 20 6b 65 79 29 0a 3b 3b 3b 20 20 20 28 73 65 74 key).;;; (set
82e0: 21 20 2a 63 6f 6f 6b 69 65 2d 73 65 71 6e 75 6d ! *cookie-seqnum
82f0: 2a 20 28 61 64 64 31 20 2a 63 6f 6f 6b 69 65 2d * (add1 *cookie-
8300: 73 65 71 6e 75 6d 2a 29 29 0a 3b 3b 3b 20 20 20 seqnum*)).;;;
8310: 3b 3b 28 70 72 69 6e 74 20 22 4d 41 4b 45 20 43 ;;(print "MAKE C
8320: 4f 4f 4b 49 45 20 43 41 4c 4c 45 44 20 2d 2d 20 OOKIE CALLED --
8330: 6f 6e 20 22 73 65 72 76 6b 65 79 22 2d 22 2a 63 on "servkey"-"*c
8340: 6f 6f 6b 69 65 2d 73 65 71 6e 75 6d 2a 29 0a 3b ookie-seqnum*).;
8350: 3b 3b 20 20 20 28 63 6f 6e 63 20 6b 65 79 20 22 ;; (conc key "
8360: 2d 22 20 2a 63 6f 6f 6b 69 65 2d 73 65 71 6e 75 -" *cookie-seqnu
8370: 6d 2a 29 0a 3b 3b 3b 20 20 20 29 0a 3b 3b 3b 20 m*).;;; ).;;;
8380: 0a 3b 3b 3b 20 3b 3b 20 64 69 73 70 61 74 63 68 .;;; ;; dispatch
8390: 20 6c 6f 63 61 6c 6c 79 20 69 66 20 70 6f 73 73 locally if poss
83a0: 69 62 6c 65 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 ible.;;; ;;.;;;
83b0: 28 64 65 66 69 6e 65 20 28 63 61 6c 6c 2d 64 65 (define (call-de
83c0: 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 65 20 61 liver-response a
83d0: 63 66 67 20 69 70 61 64 64 72 20 70 6f 72 74 20 cfg ipaddr port
83e0: 63 6f 6f 6b 69 65 20 64 61 74 61 29 0a 3b 3b 3b cookie data).;;;
83f0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 (if (and (equ
8400: 61 6c 3f 20 28 61 72 65 61 2d 6d 79 61 64 64 72 al? (area-myaddr
8410: 20 61 63 66 67 29 20 69 70 61 64 64 72 29 0a 3b acfg) ipaddr).;
8420: 3b 3b 20 09 20 20 20 28 65 71 75 61 6c 3f 20 28 ;; . (equal? (
8430: 61 72 65 61 2d 70 6f 72 74 20 20 20 20 20 61 63 area-port ac
8440: 66 67 29 20 70 6f 72 74 29 29 0a 3b 3b 3b 20 20 fg) port)).;;;
8450: 20 20 20 20 20 28 64 65 6c 69 76 65 72 2d 72 65 (deliver-re
8460: 73 70 6f 6e 73 65 20 61 63 66 67 20 63 6f 6f 6b sponse acfg cook
8470: 69 65 20 64 61 74 61 29 0a 3b 3b 3b 20 20 20 20 ie data).;;;
8480: 20 20 20 28 28 72 70 63 3a 70 72 6f 63 65 64 75 ((rpc:procedu
8490: 72 65 20 27 72 65 73 70 6f 6e 73 65 20 69 70 61 re 'response ipa
84a0: 64 64 72 20 70 6f 72 74 29 20 63 6f 6f 6b 69 65 ddr port) cookie
84b0: 20 64 61 74 61 29 29 29 0a 3b 3b 3b 20 0a 3b 3b data))).;;; .;;
84c0: 3b 20 28 64 65 66 69 6e 65 20 28 64 65 6c 69 76 ; (define (deliv
84d0: 65 72 2d 72 65 73 70 6f 6e 73 65 20 61 63 66 67 er-response acfg
84e0: 20 63 6f 6f 6b 69 65 20 64 61 74 61 29 0a 3b 3b cookie data).;;
84f0: 3b 20 20 20 28 6c 65 74 20 28 28 64 65 6c 69 76 ; (let ((deliv
8500: 65 72 2d 72 65 73 70 6f 6e 73 65 2d 73 74 61 72 er-response-star
8510: 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 t (current-milli
8520: 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 20 seconds))).;;;
8530: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
8540: 21 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 3b ! (make-thread.;
8550: 3b 3b 20 09 09 20 20 20 20 28 6c 61 6d 62 64 61 ;; .. (lambda
8560: 20 28 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 ().;;; ..
8570: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 72 69 65 (let loop ((trie
8580: 73 2d 6c 65 66 74 20 35 29 29 0a 3b 3b 3b 20 09 s-left 5)).;;; .
8590: 09 09 3b 3b 28 70 72 69 6e 74 20 22 54 4f 50 20 ..;;(print "TOP
85a0: 4f 46 20 44 45 4c 49 56 45 52 5f 52 45 53 50 4f OF DELIVER_RESPO
85b0: 4e 53 45 20 4c 4f 4f 50 3b 20 74 72 69 65 73 6c NSE LOOP; triesl
85c0: 65 66 74 3d 22 74 72 69 65 73 2d 6c 65 66 74 29 eft="tries-left)
85d0: 0a 3b 3b 3b 20 09 09 09 3b 3b 28 70 70 20 28 68 .;;; ...;;(pp (h
85e0: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
85f0: 20 28 61 72 65 61 2d 63 6f 6f 6b 69 65 32 6d 62 (area-cookie2mb
8600: 6f 78 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 09 ox acfg))).;;; .
8610: 09 09 28 6c 65 74 2a 20 28 28 6d 62 6f 78 20 28 ..(let* ((mbox (
8620: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
8630: 65 66 61 75 6c 74 20 28 61 72 65 61 2d 63 6f 6f efault (area-coo
8640: 6b 69 65 32 6d 62 6f 78 20 61 63 66 67 29 20 63 kie2mbox acfg) c
8650: 6f 6f 6b 69 65 20 23 66 29 29 29 0a 3b 3b 3b 20 ookie #f))).;;;
8660: 09 09 09 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 09 ... (cond.;;; .
8670: 09 09 20 20 20 28 28 65 71 3f 20 30 20 74 72 69 .. ((eq? 0 tri
8680: 65 73 2d 6c 65 66 74 29 0a 3b 3b 3b 20 09 09 09 es-left).;;; ...
8690: 20 20 20 20 28 70 72 69 6e 74 20 22 75 6c 65 78 (print "ulex
86a0: 3a 64 65 6c 69 76 65 72 2d 72 65 73 70 6f 6e 73 :deliver-respons
86b0: 65 3a 20 49 20 67 69 76 65 20 75 70 2e 20 4d 61 e: I give up. Ma
86c0: 69 6c 62 6f 78 20 6e 65 76 65 72 20 61 70 70 65 ilbox never appe
86d0: 61 72 65 64 2e 20 63 6f 6f 6b 69 65 3d 22 63 6f ared. cookie="co
86e0: 6f 6b 69 65 29 0a 3b 3b 3b 20 09 09 09 20 20 20 okie).;;; ...
86f0: 20 29 0a 3b 3b 3b 20 09 09 09 20 20 20 28 6d 62 ).;;; ... (mb
8700: 6f 78 0a 3b 3b 3b 20 09 09 09 20 20 20 20 3b 3b ox.;;; ... ;;
8710: 28 70 72 69 6e 74 20 22 67 6f 74 20 6d 62 6f 78 (print "got mbox
8720: 3d 22 6d 62 6f 78 22 20 20 67 6f 74 20 64 61 74 ="mbox" got dat
8730: 61 3d 22 64 61 74 61 22 20 20 73 65 6e 64 2e 22 a="data" send."
8740: 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 28 6d 61 ).;;; ... (ma
8750: 69 6c 62 6f 78 2d 73 65 6e 64 21 20 6d 62 6f 78 ilbox-send! mbox
8760: 20 64 61 74 61 29 29 0a 3b 3b 3b 20 09 09 09 20 data)).;;; ...
8770: 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 09 09 20 (else.;;; ...
8780: 20 20 20 3b 3b 28 70 72 69 6e 74 20 22 6e 6f 20 ;;(print "no
8790: 6d 62 6f 78 20 79 65 74 2e 20 20 6c 6f 6f 6b 20 mbox yet. look
87a0: 66 6f 72 20 22 63 6f 6f 6b 69 65 29 0a 3b 3b 3b for "cookie).;;;
87b0: 20 09 09 09 20 20 20 20 28 74 68 72 65 61 64 2d ... (thread-
87c0: 73 6c 65 65 70 21 20 28 2f 20 28 2d 20 36 20 74 sleep! (/ (- 6 t
87d0: 72 69 65 73 2d 6c 65 66 74 29 20 31 30 29 29 0a ries-left) 10)).
87e0: 3b 3b 3b 20 09 09 09 20 20 20 20 28 6c 6f 6f 70 ;;; ... (loop
87f0: 20 28 73 75 62 31 20 74 72 69 65 73 2d 6c 65 66 (sub1 tries-lef
8800: 74 29 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 20 t)))))).;;; ..
8810: 20 20 20 20 3b 3b 20 28 64 65 62 75 67 2d 70 70 ;; (debug-pp
8820: 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 75 6c (list (conc "ul
8830: 65 78 3a 64 65 6c 69 76 65 72 2d 72 65 73 70 6f ex:deliver-respo
8840: 6e 73 65 20 74 6f 6f 6b 20 22 20 28 2d 20 28 63 nse took " (- (c
8850: 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
8860: 6e 64 73 29 20 64 65 6c 69 76 65 72 2d 72 65 73 nds) deliver-res
8870: 70 6f 6e 73 65 2d 73 74 61 72 74 29 20 22 20 6d ponse-start) " m
8880: 73 2c 20 63 6f 6f 6b 69 65 3d 22 20 63 6f 6f 6b s, cookie=" cook
8890: 69 65 20 22 20 64 61 74 61 3d 22 29 20 64 61 74 ie " data=") dat
88a0: 61 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 a)).;;; ..
88b0: 28 73 64 62 67 3e 20 22 64 65 6c 69 76 65 72 2d (sdbg> "deliver-
88c0: 72 65 73 70 6f 6e 73 65 22 20 22 6d 61 69 6c 62 response" "mailb
88d0: 6f 78 2d 73 65 6e 64 22 20 64 65 6c 69 76 65 72 ox-send" deliver
88e0: 2d 72 65 73 70 6f 6e 73 65 2d 73 74 61 72 74 20 -response-start
88f0: 23 66 20 23 66 20 63 6f 6f 6b 69 65 29 0a 3b 3b #f #f cookie).;;
8900: 3b 20 09 09 20 20 20 20 20 20 29 0a 3b 3b 3b 20 ; .. ).;;;
8910: 09 09 20 20 20 20 28 63 6f 6e 63 20 22 64 65 6c .. (conc "del
8920: 69 76 65 72 2d 72 65 73 70 6f 6e 73 65 20 74 68 iver-response th
8930: 72 65 61 64 20 66 6f 72 20 63 6f 6f 6b 69 65 3d read for cookie=
8940: 22 63 6f 6f 6b 69 65 29 29 29 29 0a 3b 3b 3b 20 "cookie)))).;;;
8950: 20 20 23 74 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b #t).;;; .;;; ;
8960: 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 3b 20 3b 3b ; action:.;;; ;;
8970: 20 20 20 69 6d 6d 65 64 69 61 74 65 20 2d 20 71 immediate - q
8980: 75 69 63 6b 20 61 63 74 69 6f 6e 73 2c 20 6e 6f uick actions, no
8990: 20 6e 65 65 64 20 74 6f 20 70 75 74 20 69 6e 20 need to put in
89a0: 71 75 65 75 65 73 0a 3b 3b 3b 20 3b 3b 20 20 20 queues.;;; ;;
89b0: 64 62 77 72 69 74 65 20 20 20 2d 20 70 75 74 20 dbwrite - put
89c0: 69 6e 20 64 62 77 72 69 74 65 20 71 75 65 75 65 in dbwrite queue
89d0: 0a 3b 3b 3b 20 3b 3b 20 20 20 64 62 72 65 61 64 .;;; ;; dbread
89e0: 20 20 20 20 2d 20 70 75 74 20 69 6e 20 64 62 72 - put in dbr
89f0: 65 61 64 20 71 75 65 75 65 0a 3b 3b 3b 20 3b 3b ead queue.;;; ;;
8a00: 20 20 20 6f 73 6c 6f 6e 67 20 20 20 20 2d 20 6f oslong - o
8a10: 73 20 61 63 74 69 6f 6e 73 2c 20 65 2e 67 2e 20 s actions, e.g.
8a20: 64 75 2c 20 74 68 61 74 20 63 6f 75 6c 64 20 74 du, that could t
8a30: 61 6b 65 20 61 20 6c 6f 6e 67 20 74 69 6d 65 0a ake a long time.
8a40: 3b 3b 3b 20 3b 3b 20 20 20 6f 73 73 68 6f 72 74 ;;; ;; osshort
8a50: 20 20 20 2d 20 6f 73 20 61 63 74 69 6f 6e 73 20 - os actions
8a60: 74 68 61 74 20 73 68 6f 75 6c 64 20 62 65 20 71 that should be q
8a70: 75 69 63 6b 2c 20 65 2e 67 2e 20 64 66 0a 3b 3b uick, e.g. df.;;
8a80: 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 ; ;;.;;; (define
8a90: 20 28 72 65 71 75 65 73 74 20 61 63 66 67 20 66 (request acfg f
8aa0: 72 6f 6d 2d 69 70 61 64 64 72 20 66 72 6f 6d 2d rom-ipaddr from-
8ab0: 70 6f 72 74 20 73 65 72 76 6b 65 79 20 61 63 74 port servkey act
8ac0: 69 6f 6e 20 63 6f 6f 6b 69 65 20 66 6e 61 6d 65 ion cookie fname
8ad0: 20 70 61 72 61 6d 73 29 20 3b 3b 20 73 74 64 2d params) ;; std-
8ae0: 70 65 65 72 2d 68 61 6e 64 6c 65 72 0a 3b 3b 3b peer-handler.;;;
8af0: 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 55 73 65 20 ;; NOTE: Use
8b00: 72 70 63 3a 63 75 72 72 65 6e 74 2d 70 65 65 72 rpc:current-peer
8b10: 20 66 6f 72 20 67 65 74 74 69 6e 67 20 72 65 74 for getting ret
8b20: 75 72 6e 20 61 64 64 72 65 73 73 0a 3b 3b 3b 20 urn address.;;;
8b30: 20 20 28 6c 65 74 2a 20 28 28 73 74 64 2d 70 65 (let* ((std-pe
8b40: 65 72 2d 68 61 6e 64 6c 65 72 2d 73 74 61 72 74 er-handler-start
8b50: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
8b60: 65 63 6f 6e 64 73 29 29 0a 3b 3b 3b 20 09 20 3b econds)).;;; . ;
8b70: 3b 20 28 72 61 77 2d 64 61 74 61 20 20 20 20 20 ; (raw-data
8b80: 20 20 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 (alist
8b90: 2d 72 65 66 20 27 64 61 74 61 20 20 20 20 20 64 -ref 'data d
8ba0: 61 74 29 29 0a 3b 3b 3b 20 09 20 28 72 64 61 74 at)).;;; . (rdat
8bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bc0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
8bd0: 65 66 2f 64 65 66 61 75 6c 74 0a 3b 3b 3b 20 09 ef/default.;;; .
8be0: 09 09 09 20 20 28 61 72 65 61 2d 72 74 61 62 6c ... (area-rtabl
8bf0: 65 20 61 63 66 67 29 20 61 63 74 69 6f 6e 20 23 e acfg) action #
8c00: 66 29 29 20 3b 3b 20 74 68 69 73 20 6c 6f 6f 6b f)) ;; this look
8c10: 73 20 75 70 20 74 68 65 20 73 71 6c 20 71 75 65 s up the sql que
8c20: 72 79 20 6f 72 20 6f 74 68 65 72 20 64 65 74 61 ry or other deta
8c30: 69 6c 73 20 69 6e 64 65 78 65 64 20 62 79 20 74 ils indexed by t
8c40: 68 65 20 61 63 74 69 6f 6e 0a 3b 3b 3b 20 09 20 he action.;;; .
8c50: 28 77 69 74 65 6d 20 20 20 20 20 20 20 20 20 20 (witem
8c60: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 77 69 (make-wi
8c70: 74 65 6d 20 72 69 70 61 64 64 72 3a 20 66 72 6f tem ripaddr: fro
8c80: 6d 2d 69 70 61 64 64 72 20 3b 3b 20 72 68 6f 73 m-ipaddr ;; rhos
8c90: 74 3a 20 20 20 66 72 6f 6d 2d 68 6f 73 74 20 20 t: from-host
8ca0: 20 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 20 20 .;;; .....
8cb0: 72 70 6f 72 74 3a 20 20 20 66 72 6f 6d 2d 70 6f rport: from-po
8cc0: 72 74 20 20 20 61 63 74 69 6f 6e 3a 20 20 61 63 rt action: ac
8cd0: 74 69 6f 6e 0a 3b 3b 3b 20 09 09 09 09 09 20 20 tion.;;; .....
8ce0: 20 20 20 72 64 61 74 3a 20 20 20 20 72 64 61 74 rdat: rdat
8cf0: 20 20 20 20 20 20 20 20 63 6f 6f 6b 69 65 3a 20 cookie:
8d00: 20 63 6f 6f 6b 69 65 0a 3b 3b 3b 20 09 09 09 09 cookie.;;; ....
8d10: 09 20 20 20 20 20 73 65 72 76 6b 65 79 3a 20 73 . servkey: s
8d20: 65 72 76 6b 65 79 20 20 20 20 20 64 61 74 61 3a ervkey data:
8d30: 20 20 20 20 70 61 72 61 6d 73 20 3b 3b 20 54 4f params ;; TO
8d40: 44 4f 20 2d 20 72 65 6e 61 6d 65 20 64 61 74 61 DO - rename data
8d50: 20 74 6f 20 70 61 72 61 6d 73 0a 3b 3b 3b 20 09 to params.;;; .
8d60: 09 09 09 09 20 20 20 20 20 63 61 6c 6c 65 72 3a .... caller:
8d70: 20 20 28 72 70 63 3a 63 75 72 72 65 6e 74 2d 70 (rpc:current-p
8d80: 65 65 72 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 eer)))).;;;
8d90: 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f (if (not (equal?
8da0: 20 73 65 72 76 6b 65 79 20 28 61 72 65 61 2d 70 servkey (area-p
8db0: 6b 74 69 64 20 61 63 66 67 29 29 29 0a 3b 3b 3b ktid acfg))).;;;
8dc0: 20 09 60 28 23 66 20 2e 20 2c 28 63 6f 6e 63 20 .`(#f . ,(conc
8dd0: 22 49 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 79 6f "I don't know yo
8de0: 75 20 73 65 72 76 6b 65 79 3d 22 20 73 65 72 76 u servkey=" serv
8df0: 6b 65 79 20 22 2c 20 70 6b 74 69 64 3d 22 20 28 key ", pktid=" (
8e00: 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 area-pktid acfg)
8e10: 29 29 20 3b 3b 20 69 6d 6d 65 64 69 61 74 65 6c )) ;; immediatel
8e20: 79 20 72 65 74 75 72 6e 20 74 68 69 73 0a 3b 3b y return this.;;
8e30: 3b 20 09 28 6c 65 74 2a 20 28 28 63 74 79 70 65 ; .(let* ((ctype
8e40: 20 28 69 66 20 72 64 61 74 20 0a 3b 3b 3b 20 09 (if rdat .;;; .
8e50: 09 09 20 20 28 63 61 6c 6c 64 61 74 2d 63 74 79 .. (calldat-cty
8e60: 70 65 20 72 64 61 74 29 20 3b 3b 20 69 73 20 74 pe rdat) ;; is t
8e70: 68 69 73 20 6e 65 63 65 73 73 61 72 79 3f 20 74 his necessary? t
8e80: 68 65 73 65 20 73 68 6f 75 6c 64 20 62 65 20 69 hese should be i
8e90: 64 65 6e 74 69 63 61 6c 0a 3b 3b 3b 20 09 09 09 dentical.;;; ...
8ea0: 20 20 61 63 74 69 6f 6e 29 29 29 0a 3b 3b 3b 20 action))).;;;
8eb0: 09 20 20 28 73 64 62 67 3e 20 22 73 74 64 2d 70 . (sdbg> "std-p
8ec0: 65 65 72 2d 68 61 6e 64 6c 65 72 22 20 22 69 6d eer-handler" "im
8ed0: 6d 65 64 69 61 74 65 22 20 73 74 64 2d 70 65 65 mediate" std-pee
8ee0: 72 2d 68 61 6e 64 6c 65 72 2d 73 74 61 72 74 20 r-handler-start
8ef0: 23 66 20 23 66 29 0a 3b 3b 3b 20 09 20 20 28 63 #f #f).;;; . (c
8f00: 61 73 65 20 63 74 79 70 65 0a 3b 3b 3b 20 09 20 ase ctype.;;; .
8f10: 20 20 20 3b 3b 20 28 64 62 77 72 69 74 65 20 61 ;; (dbwrite a
8f20: 63 66 67 20 72 64 61 74 20 28 63 6f 6e 73 20 66 cfg rdat (cons f
8f30: 72 6f 6d 2d 69 70 61 64 64 72 20 66 72 6f 6d 2d rom-ipaddr from-
8f40: 70 6f 72 74 29 20 64 61 74 61 29 29 29 0a 3b 3b port) data))).;;
8f50: 3b 20 09 20 20 20 20 28 28 66 75 6c 6c 2d 70 69 ; . ((full-pi
8f60: 6e 67 29 20 20 60 28 23 74 20 20 22 61 63 6b 20 ng) `(#t "ack
8f70: 74 6f 20 66 75 6c 6c 20 70 69 6e 67 22 20 20 20 to full ping"
8f80: 20 20 20 20 20 2c 28 77 6f 72 6b 2d 71 75 65 75 ,(work-queu
8f90: 65 2d 61 64 64 20 61 63 66 67 20 66 6e 61 6d 65 e-add acfg fname
8fa0: 20 77 69 74 65 6d 29 20 2c 63 6f 6f 6b 69 65 29 witem) ,cookie)
8fb0: 29 0a 3b 3b 3b 20 09 20 20 20 20 28 28 72 65 73 ).;;; . ((res
8fc0: 70 6f 6e 73 65 29 20 20 20 60 28 23 74 20 20 22 ponse) `(#t "
8fd0: 61 63 6b 20 66 72 6f 6d 20 72 65 71 75 65 73 74 ack from request
8fe0: 6f 72 22 20 20 20 20 20 20 2c 28 64 65 6c 69 76 or" ,(deliv
8ff0: 65 72 2d 72 65 73 70 6f 6e 73 65 20 61 63 66 67 er-response acfg
9000: 20 66 6e 61 6d 65 20 70 61 72 61 6d 73 29 29 29 fname params)))
9010: 0a 3b 3b 3b 20 09 20 20 20 20 28 28 64 62 77 72 .;;; . ((dbwr
9020: 69 74 65 29 20 20 20 20 60 28 23 74 20 20 22 64 ite) `(#t "d
9030: 62 20 77 72 69 74 65 20 73 75 62 6d 69 74 74 65 b write submitte
9040: 64 22 20 20 20 20 20 20 2c 28 77 6f 72 6b 2d 71 d" ,(work-q
9050: 75 65 75 65 2d 61 64 64 20 61 63 66 67 20 66 6e ueue-add acfg fn
9060: 61 6d 65 20 77 69 74 65 6d 29 20 2c 63 6f 6f 6b ame witem) ,cook
9070: 69 65 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 28 ie)).;;; . ((
9080: 64 62 72 65 61 64 29 20 20 20 20 20 60 28 23 74 dbread) `(#t
9090: 20 20 22 64 62 20 72 65 61 64 20 73 75 62 6d 69 "db read submi
90a0: 74 74 65 64 22 20 20 20 20 20 20 20 2c 28 77 6f tted" ,(wo
90b0: 72 6b 2d 71 75 65 75 65 2d 61 64 64 20 61 63 66 rk-queue-add acf
90c0: 67 20 66 6e 61 6d 65 20 77 69 74 65 6d 29 20 2c g fname witem) ,
90d0: 63 6f 6f 6b 69 65 20 20 29 29 0a 3b 3b 3b 20 09 cookie )).;;; .
90e0: 20 20 20 20 28 28 64 62 72 77 29 20 20 20 20 20 ((dbrw)
90f0: 20 20 60 28 23 74 20 20 22 64 62 20 72 65 61 64 `(#t "db read
9100: 2f 77 72 69 74 65 20 73 75 62 6d 69 74 74 65 64 /write submitted
9110: 22 20 2c 63 6f 6f 6b 69 65 29 29 0a 3b 3b 3b 20 " ,cookie)).;;;
9120: 09 20 20 20 20 28 28 6f 73 73 68 6f 72 74 29 20 . ((osshort)
9130: 20 20 20 60 28 23 74 20 20 22 6f 73 20 73 68 6f `(#t "os sho
9140: 72 74 20 73 75 62 6d 69 74 74 65 64 22 20 20 20 rt submitted"
9150: 20 20 20 2c 63 6f 6f 6b 69 65 29 29 0a 3b 3b 3b ,cookie)).;;;
9160: 20 09 20 20 20 20 28 28 6f 73 6c 6f 6e 67 29 20 . ((oslong)
9170: 20 20 20 20 60 28 23 74 20 20 22 6f 73 20 6c 6f `(#t "os lo
9180: 6e 67 20 73 75 62 6d 69 74 74 65 64 22 20 20 20 ng submitted"
9190: 20 20 20 20 2c 63 6f 6f 6b 69 65 29 29 0a 3b 3b ,cookie)).;;
91a0: 3b 20 09 20 20 20 20 28 65 6c 73 65 20 20 20 20 ; . (else
91b0: 20 20 20 20 20 60 28 23 66 20 20 22 75 6e 72 65 `(#f "unre
91c0: 63 6f 67 6e 69 73 65 64 20 61 63 74 69 6f 6e 22 cognised action"
91d0: 20 20 20 20 20 2c 63 74 79 70 65 29 29 29 29 29 ,ctype)))))
91e0: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 43 )).;;; .;;; ;; C
91f0: 61 6c 6c 20 74 68 69 73 20 74 6f 20 73 74 61 72 all this to star
9200: 74 20 74 68 65 20 61 63 74 75 61 6c 20 73 65 72 t the actual ser
9210: 76 65 72 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b ver.;;; ;;.;;; ;
9220: 3b 20 73 74 61 72 74 5f 73 65 72 76 65 72 0a 3b ; start_server.;
9230: 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 20 20 6d ;; ;;.;;; ;; m
9240: 6f 64 65 3a 20 27 0a 3b 3b 3b 20 3b 3b 20 20 20 ode: '.;;; ;;
9250: 68 61 6e 64 6c 65 72 3a 20 70 72 6f 63 20 77 68 handler: proc wh
9260: 69 63 68 20 74 61 6b 65 73 20 70 6b 74 72 65 63 ich takes pktrec
9270: 69 65 76 65 64 20 61 73 20 61 72 67 75 6d 65 6e ieved as argumen
9280: 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 0a 3b 3b t.;;; ;;.;;; .;;
9290: 3b 20 28 64 65 66 69 6e 65 20 28 73 74 61 72 74 ; (define (start
92a0: 2d 73 65 72 76 65 72 20 61 63 66 67 29 0a 3b 3b -server acfg).;;
92b0: 3b 20 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 6e ; (let* ((conn
92c0: 20 28 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 (find-free-port
92d0: 2d 61 6e 64 2d 6f 70 65 6e 20 61 63 66 67 29 29 -and-open acfg))
92e0: 0a 3b 3b 3b 20 09 20 28 70 6f 72 74 20 28 61 72 .;;; . (port (ar
92f0: 65 61 2d 70 6f 72 74 20 61 63 66 67 29 29 29 0a ea-port acfg))).
9300: 3b 3b 3b 20 20 20 20 20 28 72 70 63 3a 70 75 62 ;;; (rpc:pub
9310: 6c 69 73 68 2d 70 72 6f 63 65 64 75 72 65 21 0a lish-procedure!.
9320: 3b 3b 3b 20 20 20 20 20 20 27 64 65 6c 69 73 74 ;;; 'delist
9330: 2d 64 62 0a 3b 3b 3b 20 20 20 20 20 20 28 6c 61 -db.;;; (la
9340: 6d 62 64 61 20 28 66 6e 61 6d 65 29 0a 3b 3b 3b mbda (fname).;;;
9350: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
9360: 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 61 72 65 ble-delete! (are
9370: 61 2d 64 62 73 20 61 63 66 67 29 20 66 6e 61 6d a-dbs acfg) fnam
9380: 65 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 70 e))).;;; (rp
9390: 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 c:publish-proced
93a0: 75 72 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 63 ure!.;;; 'c
93b0: 61 6c 6c 69 6e 67 2d 61 64 64 72 0a 3b 3b 3b 20 alling-addr.;;;
93c0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
93d0: 3b 3b 3b 20 20 20 20 20 20 20 20 28 72 70 63 3a ;;; (rpc:
93e0: 63 75 72 72 65 6e 74 2d 70 65 65 72 29 29 29 0a current-peer))).
93f0: 3b 3b 3b 20 20 20 20 20 28 72 70 63 3a 70 75 62 ;;; (rpc:pub
9400: 6c 69 73 68 2d 70 72 6f 63 65 64 75 72 65 21 0a lish-procedure!.
9410: 3b 3b 3b 20 20 20 20 20 20 27 70 69 6e 67 0a 3b ;;; 'ping.;
9420: 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ;; (lambda
9430: 28 29 28 72 65 61 6c 2d 70 69 6e 67 20 61 63 66 ()(real-ping acf
9440: 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 70 g))).;;; (rp
9450: 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 c:publish-proced
9460: 75 72 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 72 ure!.;;; 'r
9470: 65 71 75 65 73 74 0a 3b 3b 3b 20 20 20 20 20 20 equest.;;;
9480: 28 6c 61 6d 62 64 61 20 28 66 72 6f 6d 2d 61 64 (lambda (from-ad
9490: 64 72 20 66 72 6f 6d 2d 70 6f 72 74 20 73 65 72 dr from-port ser
94a0: 76 6b 65 79 20 61 63 74 69 6f 6e 20 63 6f 6f 6b vkey action cook
94b0: 69 65 20 64 62 6e 61 6d 65 20 70 61 72 61 6d 73 ie dbname params
94c0: 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 72 65 ).;;; (re
94d0: 71 75 65 73 74 20 61 63 66 67 20 66 72 6f 6d 2d quest acfg from-
94e0: 61 64 64 72 20 66 72 6f 6d 2d 70 6f 72 74 20 73 addr from-port s
94f0: 65 72 76 6b 65 79 20 61 63 74 69 6f 6e 20 63 6f ervkey action co
9500: 6f 6b 69 65 20 64 62 6e 61 6d 65 20 70 61 72 61 okie dbname para
9510: 6d 73 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 72 ms))).;;; (r
9520: 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 pc:publish-proce
9530: 64 75 72 65 21 0a 3b 3b 3b 20 20 20 20 20 20 27 dure!.;;; '
9540: 72 65 73 70 6f 6e 73 65 0a 3b 3b 3b 20 20 20 20 response.;;;
9550: 20 20 28 6c 61 6d 62 64 61 20 28 63 6f 6f 6b 69 (lambda (cooki
9560: 65 20 72 65 73 2d 64 61 74 29 0a 3b 3b 3b 20 20 e res-dat).;;;
9570: 20 20 20 20 20 20 28 64 65 6c 69 76 65 72 2d 72 (deliver-r
9580: 65 73 70 6f 6e 73 65 20 61 63 66 67 20 63 6f 6f esponse acfg coo
9590: 6b 69 65 20 72 65 73 2d 64 61 74 29 29 29 0a 3b kie res-dat))).;
95a0: 3b 3b 20 20 20 20 20 28 61 72 65 61 2d 72 65 61 ;; (area-rea
95b0: 64 79 2d 73 65 74 21 20 61 63 66 67 20 23 74 29 dy-set! acfg #t)
95c0: 0a 3b 3b 3b 20 20 20 20 20 28 61 72 65 61 2d 63 .;;; (area-c
95d0: 6f 6e 6e 2d 73 65 74 21 20 61 63 66 67 20 63 6f onn-set! acfg co
95e0: 6e 6e 29 0a 3b 3b 3b 20 20 20 20 20 28 28 72 70 nn).;;; ((rp
95f0: 63 3a 6d 61 6b 65 2d 73 65 72 76 65 72 20 63 6f c:make-server co
9600: 6e 6e 29 20 23 66 29 29 29 3b 3b 20 28 28 74 63 nn) #f)));; ((tc
9610: 70 2d 6c 69 73 74 65 6e 20 28 72 70 63 3a 64 65 p-listen (rpc:de
9620: 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 fault-server-por
9630: 74 29 29 20 23 74 29 0a 3b 3b 3b 20 0a 3b 3b 3b t)) #t).;;; .;;;
9640: 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 6c .;;; (define (l
9650: 61 75 6e 63 68 20 61 63 66 67 29 20 3b 3b 20 20 aunch acfg) ;;
9660: 23 21 6f 70 74 69 6f 6e 61 6c 20 28 70 72 6f 63 #!optional (proc
9670: 20 73 74 64 2d 70 65 65 72 2d 68 61 6e 64 6c 65 std-peer-handle
9680: 72 29 29 0a 3b 3b 3b 20 20 20 28 70 72 69 6e 74 r)).;;; (print
9690: 20 22 73 74 61 72 74 69 6e 67 20 6c 61 75 6e 63 "starting launc
96a0: 68 22 29 0a 3b 3b 3b 20 20 20 28 75 70 64 61 74 h").;;; (updat
96b0: 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 20 e-known-servers
96c0: 61 63 66 67 29 20 3b 3b 20 67 6f 74 74 61 20 64 acfg) ;; gotta d
96d0: 6f 20 74 68 69 73 20 6f 6e 20 65 76 65 72 79 20 o this on every
96e0: 73 74 61 72 74 20 28 74 68 75 73 20 77 68 79 20 start (thus why
96f0: 6c 69 6d 69 74 20 6e 75 6d 62 65 72 20 6f 66 20 limit number of
9700: 70 75 62 6c 69 63 69 73 65 64 20 73 65 72 76 65 publicised serve
9710: 72 73 29 0a 3b 3b 3b 20 20 20 23 3b 28 6c 65 74 rs).;;; #;(let
9720: 20 28 28 6f 72 69 67 69 6e 61 6c 2d 68 61 6e 64 ((original-hand
9730: 6c 65 72 20 28 63 75 72 72 65 6e 74 2d 65 78 63 ler (current-exc
9740: 65 70 74 69 6f 6e 2d 68 61 6e 64 6c 65 72 29 29 eption-handler))
9750: 29 20 3b 3b 20 69 73 20 74 68 0a 3b 3b 3b 20 20 ) ;; is th.;;;
9760: 20 20 20 28 6c 61 6d 62 64 61 20 28 65 78 63 65 (lambda (exce
9770: 70 74 69 6f 6e 29 0a 3b 3b 3b 20 20 20 20 20 20 ption).;;;
9780: 20 28 73 65 72 76 65 72 2d 65 78 69 74 2d 70 72 (server-exit-pr
9790: 6f 63 65 64 75 72 65 29 0a 3b 3b 3b 20 20 20 20 ocedure).;;;
97a0: 20 20 20 28 6f 72 69 67 69 6e 61 6c 2d 68 61 6e (original-han
97b0: 64 6c 65 72 20 65 78 63 65 70 74 69 6f 6e 29 29 dler exception))
97c0: 29 0a 3b 3b 3b 20 20 20 28 6f 6e 2d 65 78 69 74 ).;;; (on-exit
97d0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 3b 20 (lambda ().;;;
97e0: 09 20 20 20 20 20 28 73 68 75 74 64 6f 77 6e 20 . (shutdown
97f0: 61 63 66 67 29 29 29 20 3b 3b 20 28 66 69 6e 61 acfg))) ;; (fina
9800: 6c 69 7a 65 2d 61 6c 6c 2d 64 62 2d 68 61 6e 64 lize-all-db-hand
9810: 6c 65 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 les acfg))).;;;
9820: 20 20 3b 3b 20 73 65 74 20 75 70 20 74 68 65 20 ;; set up the
9830: 72 70 63 20 68 61 6e 64 6c 65 72 0a 3b 3b 3b 20 rpc handler.;;;
9840: 20 20 28 6c 65 74 2a 20 28 28 74 68 31 20 20 28 (let* ((th1 (
9850: 6d 61 6b 65 2d 74 68 72 65 61 64 0a 3b 3b 3b 20 make-thread.;;;
9860: 09 09 28 6c 61 6d 62 64 61 20 28 29 28 73 74 61 ..(lambda ()(sta
9870: 72 74 2d 73 65 72 76 65 72 20 61 63 66 67 29 29 rt-server acfg))
9880: 0a 3b 3b 3b 20 09 09 22 73 65 72 76 65 72 20 74 .;;; .."server t
9890: 68 72 65 61 64 22 29 29 0a 3b 3b 3b 20 09 20 28 hread")).;;; . (
98a0: 74 68 32 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 th2 (make-thre
98b0: 61 64 0a 3b 3b 3b 20 09 09 20 28 6c 61 6d 62 64 ad.;;; .. (lambd
98c0: 61 20 28 29 0a 3b 3b 3b 20 09 09 20 20 20 28 70 a ().;;; .. (p
98d0: 72 69 6e 74 20 22 74 68 32 20 73 74 61 72 74 69 rint "th2 starti
98e0: 6e 67 22 29 0a 3b 3b 3b 20 09 09 20 20 20 28 6c ng").;;; .. (l
98f0: 65 74 20 6c 6f 6f 70 20 28 29 0a 3b 3b 3b 20 09 et loop ().;;; .
9900: 09 20 20 20 20 20 28 77 6f 72 6b 2d 71 75 65 75 . (work-queu
9910: 65 2d 70 72 6f 63 65 73 73 6f 72 20 61 63 66 67 e-processor acfg
9920: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 70 72 ).;;; .. (pr
9930: 69 6e 74 20 22 77 6f 72 6b 2d 71 75 65 75 65 2d int "work-queue-
9940: 70 72 6f 63 65 73 73 6f 72 20 63 72 61 73 68 65 processor crashe
9950: 64 21 22 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 d!").;;; ..
9960: 28 6c 6f 6f 70 29 29 29 0a 3b 3b 3b 20 09 09 20 (loop))).;;; ..
9970: 22 77 6f 72 6b 20 71 75 65 75 65 20 74 68 72 65 "work queue thre
9980: 61 64 22 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 ad"))).;;; (
9990: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
99a0: 31 29 0a 3b 3b 3b 20 20 20 20 20 28 74 68 72 65 1).;;; (thre
99b0: 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 3b ad-start! th2).;
99c0: 3b 3b 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 ;; (let loop
99d0: 20 28 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 74 ().;;; (t
99e0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 hread-sleep! 0.0
99f0: 32 35 29 0a 3b 3b 3b 20 20 20 20 20 20 20 28 69 25).;;; (i
9a00: 66 20 28 61 72 65 61 2d 72 65 61 64 79 20 61 63 f (area-ready ac
9a10: 66 67 29 0a 3b 3b 3b 20 09 20 20 23 74 0a 3b 3b fg).;;; . #t.;;
9a20: 3b 20 09 20 20 28 6c 6f 6f 70 29 29 29 0a 3b 3b ; . (loop))).;;
9a30: 3b 20 20 20 20 20 3b 3b 20 61 74 74 65 6d 70 74 ; ;; attempt
9a40: 20 74 6f 20 66 69 78 20 6d 79 20 61 64 64 72 65 to fix my addre
9a50: 73 73 0a 3b 3b 3b 20 20 20 20 20 28 6c 65 74 2a ss.;;; (let*
9a60: 20 28 28 61 6c 6c 2d 61 64 64 72 20 28 67 65 74 ((all-addr (get
9a70: 2d 61 6c 6c 2d 69 70 73 2d 73 6f 72 74 65 64 29 -all-ips-sorted)
9a80: 29 29 09 20 20 20 20 20 3b 3b 20 63 6f 75 6c 64 )). ;; could
9a90: 20 75 73 65 20 28 74 63 70 2d 61 64 64 72 65 73 use (tcp-addres
9aa0: 73 65 73 20 63 6f 6e 6e 29 3f 0a 3b 3b 3b 20 20 ses conn)?.;;;
9ab0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
9ac0: 28 72 65 6d 2d 61 64 64 72 73 20 61 6c 6c 2d 61 (rem-addrs all-a
9ad0: 64 64 72 29 29 0a 3b 3b 3b 20 09 28 69 66 20 28 ddr)).;;; .(if (
9ae0: 6e 75 6c 6c 3f 20 72 65 6d 2d 61 64 64 72 73 29 null? rem-addrs)
9af0: 0a 3b 3b 3b 20 09 20 20 20 20 28 62 65 67 69 6e .;;; . (begin
9b00: 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 70 72 69 .;;; . (pri
9b10: 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 nt "ERROR: Faile
9b20: 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 d to figure out
9b30: 74 68 65 20 69 70 20 61 64 64 72 65 73 73 20 6f the ip address o
9b40: 66 20 6d 79 73 65 6c 66 20 61 73 20 61 20 73 65 f myself as a se
9b50: 72 76 65 72 2e 20 47 69 76 69 6e 67 20 75 70 2e rver. Giving up.
9b60: 22 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 28 65 ").;;; . (e
9b70: 78 69 74 20 31 29 29 20 3b 3b 20 42 55 47 20 43 xit 1)) ;; BUG C
9b80: 68 61 6e 67 65 6d 65 20 74 6f 20 72 61 69 73 69 hangeme to raisi
9b90: 6e 67 20 61 6e 20 65 78 63 65 70 74 69 6f 6e 0a ng an exception.
9ba0: 3b 3b 3b 20 09 09 0a 3b 3b 3b 20 09 20 20 20 20 ;;; ...;;; .
9bb0: 28 6c 65 74 2a 20 28 28 61 64 64 72 20 20 20 20 (let* ((addr
9bc0: 20 20 28 63 61 72 20 72 65 6d 2d 61 64 64 72 73 (car rem-addrs
9bd0: 29 29 0a 3b 3b 3b 20 09 09 20 20 20 28 67 6f 6f )).;;; .. (goo
9be0: 64 2d 61 64 64 72 20 28 68 61 6e 64 6c 65 2d 65 d-addr (handle-e
9bf0: 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 3b 20 09 09 xceptions.;;; ..
9c00: 09 09 20 20 65 78 6e 0a 3b 3b 3b 20 09 09 09 09 .. exn.;;; ....
9c10: 20 20 23 66 0a 3b 3b 3b 20 09 09 09 09 28 28 72 #f.;;; ....((r
9c20: 70 63 3a 70 72 6f 63 65 64 75 72 65 20 27 63 61 pc:procedure 'ca
9c30: 6c 6c 69 6e 67 2d 61 64 64 72 20 61 64 64 72 20 lling-addr addr
9c40: 28 61 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 (area-port acfg)
9c50: 29 29 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 ))))).;;; .
9c60: 20 28 69 66 20 67 6f 6f 64 2d 61 64 64 72 0a 3b (if good-addr.;
9c70: 3b 3b 20 09 09 20 20 28 62 65 67 69 6e 0a 3b 3b ;; .. (begin.;;
9c80: 3b 20 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 ; .. (print "
9c90: 47 6f 74 20 67 6f 6f 64 2d 61 64 64 72 20 6f 66 Got good-addr of
9ca0: 20 22 20 67 6f 6f 64 2d 61 64 64 72 29 0a 3b 3b " good-addr).;;
9cb0: 3b 20 09 09 20 20 20 20 28 61 72 65 61 2d 6d 79 ; .. (area-my
9cc0: 61 64 64 72 2d 73 65 74 21 20 61 63 66 67 20 67 addr-set! acfg g
9cd0: 6f 6f 64 2d 61 64 64 72 29 29 0a 3b 3b 3b 20 09 ood-addr)).;;; .
9ce0: 09 20 20 28 6c 6f 6f 70 20 28 63 64 72 20 72 65 . (loop (cdr re
9cf0: 6d 2d 61 64 64 72 73 29 29 29 29 29 29 29 0a 3b m-addrs))))))).;
9d00: 3b 3b 20 20 20 20 20 28 72 65 67 69 73 74 65 72 ;; (register
9d10: 2d 6e 6f 64 65 20 61 63 66 67 20 28 61 72 65 61 -node acfg (area
9d20: 2d 6d 79 61 64 64 72 20 61 63 66 67 29 28 61 72 -myaddr acfg)(ar
9d30: 65 61 2d 70 6f 72 74 20 61 63 66 67 29 29 0a 3b ea-port acfg)).;
9d40: 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 49 ;; (print "I
9d50: 4e 46 4f 3a 20 53 65 72 76 65 72 20 73 74 61 72 NFO: Server star
9d60: 74 65 64 20 6f 6e 20 22 20 28 61 72 65 61 2d 6d ted on " (area-m
9d70: 79 61 64 64 72 20 61 63 66 67 29 20 22 3a 22 20 yaddr acfg) ":"
9d80: 28 61 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 (area-port acfg)
9d90: 29 0a 3b 3b 3b 20 20 20 20 20 3b 3b 20 28 75 70 ).;;; ;; (up
9da0: 64 61 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 date-known-serve
9db0: 72 73 20 61 63 66 67 29 20 3b 3b 20 67 6f 74 74 rs acfg) ;; gott
9dc0: 61 20 64 6f 20 74 68 69 73 20 6f 6e 20 65 76 65 a do this on eve
9dd0: 72 79 20 73 74 61 72 74 20 28 74 68 75 73 20 77 ry start (thus w
9de0: 68 79 20 6c 69 6d 69 74 20 6e 75 6d 62 65 72 20 hy limit number
9df0: 6f 66 20 70 75 62 6c 69 63 69 73 65 64 20 73 65 of publicised se
9e00: 72 76 65 72 73 29 0a 3b 3b 3b 20 20 20 20 20 29 rvers).;;; )
9e10: 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 ).;;; .;;; (defi
9e20: 6e 65 20 28 63 6c 65 61 72 2d 73 65 72 76 65 72 ne (clear-server
9e30: 2d 70 6b 74 20 61 63 66 67 29 0a 3b 3b 3b 20 20 -pkt acfg).;;;
9e40: 20 28 6c 65 74 20 28 28 70 6b 74 66 20 28 61 72 (let ((pktf (ar
9e50: 65 61 2d 70 6b 74 66 69 6c 65 20 61 63 66 67 29 ea-pktfile acfg)
9e60: 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 70 )).;;; (if p
9e70: 6b 74 66 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 ktf (delete-file
9e80: 2a 20 70 6b 74 66 29 29 29 29 0a 3b 3b 3b 20 0a * pktf)))).;;; .
9e90: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 68 75 ;;; (define (shu
9ea0: 74 64 6f 77 6e 20 61 63 66 67 29 0a 3b 3b 3b 20 tdown acfg).;;;
9eb0: 20 20 28 6c 65 74 20 28 3b 3b 28 63 6f 6e 6e 20 (let (;;(conn
9ec0: 28 61 72 65 61 2d 63 6f 6e 6e 20 20 20 20 61 63 (area-conn ac
9ed0: 66 67 29 29 0a 3b 3b 3b 20 09 28 70 6b 74 66 20 fg)).;;; .(pktf
9ee0: 28 61 72 65 61 2d 70 6b 74 66 69 6c 65 20 61 63 (area-pktfile ac
9ef0: 66 67 29 29 0a 3b 3b 3b 20 09 28 70 6f 72 74 20 fg)).;;; .(port
9f00: 28 61 72 65 61 2d 70 6f 72 74 20 20 20 20 61 63 (area-port ac
9f10: 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 fg))).;;; (i
9f20: 66 20 70 6b 74 66 20 28 64 65 6c 65 74 65 2d 66 f pktf (delete-f
9f30: 69 6c 65 2a 20 70 6b 74 66 29 29 0a 3b 3b 3b 20 ile* pktf)).;;;
9f40: 20 20 20 20 28 73 65 6e 64 2d 61 6c 6c 20 22 69 (send-all "i
9f50: 6d 73 68 75 74 74 69 6e 67 64 6f 77 6e 22 29 0a mshuttingdown").
9f60: 3b 3b 3b 20 20 20 20 20 3b 3b 20 28 72 70 63 3a ;;; ;; (rpc:
9f70: 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 close-all-connec
9f80: 74 69 6f 6e 73 21 29 20 3b 3b 20 64 6f 6e 27 74 tions!) ;; don't
9f90: 20 6b 6e 6f 77 20 69 66 20 74 68 69 73 20 69 73 know if this is
9fa0: 20 61 63 74 75 61 6c 6c 79 20 6e 65 65 64 65 64 actually needed
9fb0: 0a 3b 3b 3b 20 20 20 20 20 28 66 69 6e 61 6c 69 .;;; (finali
9fc0: 7a 65 2d 61 6c 6c 2d 64 62 2d 68 61 6e 64 6c 65 ze-all-db-handle
9fd0: 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 0a 3b s acfg))).;;; .;
9fe0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 6e 64 ;; (define (send
9ff0: 2d 61 6c 6c 20 6d 73 67 29 0a 3b 3b 3b 20 20 20 -all msg).;;;
a000: 23 66 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 #f).;;; .;;; ;;
a010: 67 69 76 65 6e 20 61 20 61 72 65 61 20 72 65 63 given a area rec
a020: 6f 72 64 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 ord look up all
a030: 74 68 65 20 70 61 63 6b 65 74 73 0a 3b 3b 3b 20 the packets.;;;
a040: 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;.;;; (define (
a050: 67 65 74 2d 61 6c 6c 2d 73 65 72 76 65 72 2d 70 get-all-server-p
a060: 6b 74 73 20 61 63 66 67 29 0a 3b 3b 3b 20 20 20 kts acfg).;;;
a070: 28 6c 65 74 20 28 28 61 6c 6c 2d 70 6b 74 2d 66 (let ((all-pkt-f
a080: 69 6c 65 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 iles (glob (conc
a090: 20 28 61 72 65 61 2d 70 6b 74 73 64 69 72 20 61 (area-pktsdir a
a0a0: 63 66 67 29 20 22 2f 2a 2e 70 6b 74 22 29 29 29 cfg) "/*.pkt")))
a0b0: 29 0a 3b 3b 3b 20 20 20 20 20 28 6d 61 70 20 28 ).;;; (map (
a0c0: 6c 61 6d 62 64 61 20 28 70 6b 74 2d 66 69 6c 65 lambda (pkt-file
a0d0: 29 0a 3b 3b 3b 20 09 20 20 20 28 72 65 61 64 2d ).;;; . (read-
a0e0: 70 6b 74 2d 3e 61 6c 69 73 74 20 70 6b 74 2d 66 pkt->alist pkt-f
a0f0: 69 6c 65 20 70 6b 74 73 70 65 63 3a 20 2a 70 6b ile pktspec: *pk
a100: 74 73 70 65 63 2a 29 29 0a 3b 3b 3b 20 09 20 61 tspec*)).;;; . a
a110: 6c 6c 2d 70 6b 74 2d 66 69 6c 65 73 29 29 29 0a ll-pkt-files))).
a120: 3b 3b 3b 20 0a 3b 3b 3b 20 23 3b 28 28 5a 20 2e ;;; .;;; #;((Z .
a130: 20 22 39 61 30 32 31 32 33 30 32 32 39 35 61 31 "9a0212302295a1
a140: 39 36 31 30 64 35 37 39 36 66 63 65 30 33 37 30 9610d5796fce0370
a150: 66 61 31 33 30 37 35 38 65 39 22 29 0a 3b 3b 3b fa130758e9").;;;
a160: 20 20 20 28 70 6f 72 74 20 2e 20 22 33 34 38 32 (port . "3482
a170: 37 22 29 0a 3b 3b 3b 20 20 20 28 70 69 64 20 2e 7").;;; (pid .
a180: 20 22 32 38 37 34 38 22 29 0a 3b 3b 3b 20 20 20 "28748").;;;
a190: 28 68 6f 73 74 6e 61 6d 65 20 2e 20 22 7a 65 75 (hostname . "zeu
a1a0: 73 22 29 0a 3b 3b 3b 20 20 20 28 54 20 2e 20 22 s").;;; (T . "
a1b0: 73 65 72 76 65 72 22 29 0a 3b 3b 3b 20 20 20 28 server").;;; (
a1c0: 44 20 2e 20 22 31 35 34 39 34 32 37 30 33 32 2e D . "1549427032.
a1d0: 30 22 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 23 3b 0")).;;; .;;; #;
a1e0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6d 79 2d (define (get-my-
a1f0: 62 65 73 74 2d 61 64 64 72 65 73 73 29 0a 3b 3b best-address).;;
a200: 3b 20 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d 6d ; (let ((all-m
a210: 79 2d 61 64 64 72 65 73 73 65 73 20 28 67 65 74 y-addresses (get
a220: 2d 61 6c 6c 2d 69 70 73 29 29 29 20 3b 3b 20 28 -all-ips))) ;; (
a230: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f vector->list (ho
a240: 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 stinfo-addresses
a250: 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 (hostname->host
a260: 69 6e 66 6f 20 28 67 65 74 2d 68 6f 73 74 2d 6e info (get-host-n
a270: 61 6d 65 29 29 29 29 29 29 0a 3b 3b 3b 20 20 20 ame)))))).;;;
a280: 20 20 28 63 6f 6e 64 0a 3b 3b 3b 20 20 20 20 20 (cond.;;;
a290: 20 28 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d ((null? all-my-
a2a0: 61 64 64 72 65 73 73 65 73 29 0a 3b 3b 3b 20 20 addresses).;;;
a2b0: 20 20 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e (get-host-n
a2c0: 61 6d 65 29 29 20 20 20 20 20 20 20 20 20 20 20 ame))
a2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
a2f0: 3b 20 6e 6f 20 69 6e 74 65 72 66 61 63 65 73 3f ; no interfaces?
a300: 0a 3b 3b 3b 20 20 20 20 20 20 28 28 65 71 3f 20 .;;; ((eq?
a310: 28 6c 65 6e 67 74 68 20 61 6c 6c 2d 6d 79 2d 61 (length all-my-a
a320: 64 64 72 65 73 73 65 73 29 20 31 29 0a 3b 3b 3b ddresses) 1).;;;
a330: 20 20 20 20 20 20 20 28 69 70 2d 3e 73 74 72 69 (ip->stri
a340: 6e 67 20 28 63 61 72 20 61 6c 6c 2d 6d 79 2d 61 ng (car all-my-a
a350: 64 64 72 65 73 73 65 73 29 29 29 20 20 20 20 20 ddresses)))
a360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a370: 20 3b 3b 20 6f 6e 6c 79 20 6f 6e 65 20 74 6f 20 ;; only one to
a380: 63 68 6f 6f 73 65 20 66 72 6f 6d 2c 20 6a 75 73 choose from, jus
a390: 74 20 67 6f 20 77 69 74 68 20 69 74 0a 3b 3b 3b t go with it.;;;
a3a0: 20 20 20 20 20 20 28 65 6c 73 65 20 0a 3b 3b 3b (else .;;;
a3b0: 20 20 20 20 20 20 20 28 69 70 2d 3e 73 74 72 69 (ip->stri
a3c0: 6e 67 20 28 63 61 72 20 28 66 69 6c 74 65 72 20 ng (car (filter
a3d0: 28 6c 61 6d 62 64 61 20 28 78 29 20 20 20 20 20 (lambda (x)
a3e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3f0: 20 3b 3b 20 74 61 6b 65 20 61 6e 79 20 62 75 74 ;; take any but
a400: 20 31 32 37 2e 0a 3b 3b 3b 20 09 09 09 09 20 28 127..;;; .... (
a410: 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 74 not (eq? (u8vect
a420: 6f 72 2d 72 65 66 20 78 20 30 29 20 31 32 37 29 or-ref x 0) 127)
a430: 29 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 )).;;; ...
a440: 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 73 73 65 all-my-addresse
a450: 73 29 29 29 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b s))))))).;;; .;;
a460: 3b 20 3b 3b 20 77 68 6f 61 6d 69 3f 20 49 20 61 ; ;; whoami? I a
a470: 6d 20 6d 79 20 70 6b 74 0a 3b 3b 3b 20 3b 3b 0a m my pkt.;;; ;;.
a480: 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 77 68 6f ;;; (define (who
a490: 61 6d 69 3f 20 61 63 66 67 29 0a 3b 3b 3b 20 20 ami? acfg).;;;
a4a0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
a4b0: 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d 68 /default (area-h
a4c0: 6f 73 74 73 20 61 63 66 67 29 28 61 72 65 61 2d osts acfg)(area-
a4d0: 70 6b 74 69 64 20 61 63 66 67 29 20 23 66 29 29 pktid acfg) #f))
a4e0: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d .;;; .;;; ;;====
a4f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a530: 3d 3d 0a 3b 3b 3b 20 3b 3b 20 22 43 6c 69 65 6e ==.;;; ;; "Clien
a540: 74 20 73 69 64 65 22 20 6f 70 65 72 61 74 69 6f t side" operatio
a550: 6e 73 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d ns.;;; ;;=======
a560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
a5a0: 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 ;;; .;;; (define
a5b0: 20 28 73 61 66 65 2d 63 61 6c 6c 20 63 61 6c 6c (safe-call call
a5c0: 2d 6b 65 79 20 68 6f 73 74 20 70 6f 72 74 20 2e -key host port .
a5d0: 20 70 61 72 61 6d 73 29 0a 3b 3b 3b 20 20 20 28 params).;;; (
a5e0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
a5f0: 73 0a 3b 3b 3b 20 20 20 20 65 78 6e 0a 3b 3b 3b s.;;; exn.;;;
a600: 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 20 (begin.;;;
a610: 20 20 20 20 28 70 72 69 6e 74 20 22 43 61 6c 6c (print "Call
a620: 20 22 20 63 61 6c 6c 2d 6b 65 79 20 22 20 74 6f " call-key " to
a630: 20 22 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 " host ":" port
a640: 20 22 20 66 61 69 6c 65 64 22 29 0a 3b 3b 3b 20 " failed").;;;
a650: 20 20 20 20 20 23 66 29 0a 3b 3b 3b 20 20 20 20 #f).;;;
a660: 28 61 70 70 6c 79 20 28 72 70 63 3a 70 72 6f 63 (apply (rpc:proc
a670: 65 64 75 72 65 20 63 61 6c 6c 2d 6b 65 79 20 68 edure call-key h
a680: 6f 73 74 20 70 6f 72 74 29 20 70 61 72 61 6d 73 ost port) params
a690: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 ))).;;; .;;; ;;
a6a0: 3b 3b 20 63 6f 6e 76 65 72 74 20 74 6f 2f 66 72 ;; convert to/fr
a6b0: 6f 6d 20 73 74 72 69 6e 67 20 2f 20 73 65 78 70 om string / sexp
a6c0: 72 0a 3b 3b 3b 20 3b 3b 20 0a 3b 3b 3b 20 3b 3b r.;;; ;; .;;; ;;
a6d0: 20 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 (define (string
a6e0: 2d 3e 73 65 78 70 72 20 73 74 72 29 0a 3b 3b 3b ->sexpr str).;;;
a6f0: 20 3b 3b 20 20 20 28 69 66 20 28 73 74 72 69 6e ;; (if (strin
a700: 67 3f 20 73 74 72 29 0a 3b 3b 3b 20 3b 3b 20 20 g? str).;;; ;;
a710: 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
a720: 2d 66 72 6f 6d 2d 73 74 72 69 6e 67 20 73 74 72 -from-string str
a730: 20 72 65 61 64 29 0a 3b 3b 3b 20 3b 3b 20 20 20 read).;;; ;;
a740: 20 20 20 20 73 74 72 29 29 0a 3b 3b 3b 20 3b 3b str)).;;; ;;
a750: 20 0a 3b 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 .;;; ;; (define
a760: 20 28 73 65 78 70 72 2d 3e 73 74 72 69 6e 67 20 (sexpr->string
a770: 73 29 0a 3b 3b 3b 20 3b 3b 20 20 20 28 77 69 74 s).;;; ;; (wit
a780: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 h-output-to-stri
a790: 6e 67 20 28 6c 61 6d 62 64 61 20 28 29 28 77 72 ng (lambda ()(wr
a7a0: 69 74 65 20 73 29 29 29 29 0a 3b 3b 3b 20 0a 3b ite s)))).;;; .;
a7b0: 3b 3b 20 3b 3b 20 69 73 20 74 68 65 20 73 65 72 ;; ;; is the ser
a7c0: 76 65 72 20 61 6c 69 76 65 3f 0a 3b 3b 3b 20 3b ver alive?.;;; ;
a7d0: 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 70 ;.;;; (define (p
a7e0: 69 6e 67 20 61 63 66 67 20 68 6f 73 74 20 70 6f ing acfg host po
a7f0: 72 74 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 rt).;;; (let*
a800: 28 28 6d 79 61 64 64 72 20 20 20 20 20 28 61 72 ((myaddr (ar
a810: 65 61 2d 6d 79 61 64 64 72 20 61 63 66 67 29 29 ea-myaddr acfg))
a820: 0a 3b 3b 3b 20 09 20 28 6d 79 70 6f 72 74 20 20 .;;; . (myport
a830: 20 20 20 28 61 72 65 61 2d 70 6f 72 74 20 20 20 (area-port
a840: 61 63 66 67 29 29 0a 3b 3b 3b 20 09 20 28 73 74 acfg)).;;; . (st
a850: 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e art-time (curren
a860: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 t-milliseconds))
a870: 0a 3b 3b 3b 20 09 20 28 72 65 73 20 20 20 20 20 .;;; . (res
a880: 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 (if (and (equ
a890: 61 6c 3f 20 6d 79 61 64 64 72 20 68 6f 73 74 29 al? myaddr host)
a8a0: 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 20 28 65 .;;; ... (e
a8b0: 71 75 61 6c 3f 20 6d 79 70 6f 72 74 20 70 6f 72 qual? myport por
a8c0: 74 29 29 0a 3b 3b 3b 20 09 09 09 20 28 72 65 61 t)).;;; ... (rea
a8d0: 6c 2d 70 69 6e 67 20 61 63 66 67 29 0a 3b 3b 3b l-ping acfg).;;;
a8e0: 20 09 09 09 20 28 28 72 70 63 3a 70 72 6f 63 65 ... ((rpc:proce
a8f0: 64 75 72 65 20 27 70 69 6e 67 20 68 6f 73 74 20 dure 'ping host
a900: 70 6f 72 74 29 29 29 29 29 0a 3b 3b 3b 20 20 20 port))))).;;;
a910: 20 20 28 63 6f 6e 73 20 28 2d 20 28 63 75 72 72 (cons (- (curr
a920: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
a930: 29 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 3b 3b ) start-time).;;
a940: 3b 20 09 20 20 72 65 73 29 29 29 0a 3b 3b 3b 20 ; . res))).;;;
a950: 0a 3b 3b 3b 20 3b 3b 20 72 65 74 75 72 6e 73 20 .;;; ;; returns
a960: 28 20 69 70 61 64 64 72 20 70 6f 72 74 20 61 6c ( ipaddr port al
a970: 69 73 74 2d 66 6e 61 6d 65 3d 3e 72 61 6e 64 6e ist-fname=>randn
a980: 75 6d 20 29 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 um ).;;; (define
a990: 20 28 72 65 61 6c 2d 70 69 6e 67 20 61 63 66 67 (real-ping acfg
a9a0: 29 0a 3b 3b 3b 20 20 20 60 28 2c 28 61 72 65 61 ).;;; `(,(area
a9b0: 2d 6d 79 61 64 64 72 20 61 63 66 67 29 20 2c 28 -myaddr acfg) ,(
a9c0: 61 72 65 61 2d 70 6f 72 74 20 61 63 66 67 29 20 area-port acfg)
a9d0: 2c 28 67 65 74 2d 68 6f 73 74 2d 73 74 61 74 73 ,(get-host-stats
a9e0: 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 0a 3b 3b acfg))).;;; .;;
a9f0: 3b 20 3b 3b 20 69 73 20 74 68 65 20 73 65 72 76 ; ;; is the serv
aa00: 65 72 20 61 6c 69 76 65 20 41 4e 44 20 74 68 65 er alive AND the
aa10: 20 71 75 65 75 65 73 20 70 72 6f 63 65 73 73 69 queues processi
aa20: 6e 67 3f 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 23 ng?.;;; ;;.;;; #
aa30: 3b 28 64 65 66 69 6e 65 20 28 66 75 6c 6c 2d 70 ;(define (full-p
aa40: 69 6e 67 20 61 63 66 67 20 73 65 72 76 70 6b 74 ing acfg servpkt
aa50: 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 ).;;; (let* ((
aa60: 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
aa70: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
aa80: 29 29 0a 3b 3b 3b 20 09 20 28 72 65 73 20 20 20 )).;;; . (res
aa90: 20 20 20 20 20 28 73 65 6e 64 2d 6d 65 73 73 61 (send-messa
aaa0: 67 65 20 61 63 66 67 20 73 65 72 76 70 6b 74 20 ge acfg servpkt
aab0: 27 28 66 75 6c 6c 2d 70 69 6e 67 29 20 27 66 75 '(full-ping) 'fu
aac0: 6c 6c 2d 70 69 6e 67 29 29 29 0a 3b 3b 3b 20 20 ll-ping))).;;;
aad0: 20 20 20 28 63 6f 6e 73 20 28 2d 20 28 63 75 72 (cons (- (cur
aae0: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
aaf0: 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 3b s) start-time).;
ab00: 3b 3b 20 09 20 20 72 65 73 29 29 29 20 3b 3b 20 ;; . res))) ;;
ab10: 28 65 71 75 61 6c 3f 20 72 65 73 20 22 67 6f 74 (equal? res "got
ab20: 20 70 69 6e 67 22 29 29 29 29 0a 3b 3b 3b 20 0a ping")))).;;; .
ab30: 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 6c 6f 6f 6b ;;; .;;; ;; look
ab40: 20 75 70 20 61 6c 6c 20 70 6b 74 73 20 61 6e 64 up all pkts and
ab50: 20 67 65 74 20 74 68 65 20 73 65 72 76 65 72 20 get the server
ab60: 69 64 20 28 74 68 65 20 68 61 73 68 29 2c 20 70 id (the hash), p
ab70: 6f 72 74 2c 20 68 6f 73 74 2f 69 70 0a 3b 3b 3b ort, host/ip.;;;
ab80: 20 3b 3b 20 73 74 6f 72 65 20 74 68 69 73 20 69 ;; store this i
ab90: 6e 66 6f 20 69 6e 20 61 63 66 67 0a 3b 3b 3b 20 nfo in acfg.;;;
aba0: 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 20 6e 75 ;; return the nu
abb0: 6d 62 65 72 20 6f 66 20 72 65 73 70 6f 6e 73 69 mber of responsi
abc0: 76 65 20 73 65 72 76 65 72 73 20 66 6f 75 6e 64 ve servers found
abd0: 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 3b 3b 20 44 .;;; ;;.;;; ;; D
abe0: 4f 20 4e 4f 54 20 56 45 52 49 46 59 20 54 48 41 O NOT VERIFY THA
abf0: 54 20 54 48 45 20 53 45 52 56 45 52 20 49 53 20 T THE SERVER IS
ac00: 41 4c 49 56 45 20 48 45 52 45 2e 20 54 68 69 73 ALIVE HERE. This
ac10: 20 69 73 20 63 61 6c 6c 65 64 20 61 74 20 74 69 is called at ti
ac20: 6d 65 73 20 77 68 65 72 65 20 74 68 65 20 63 75 mes where the cu
ac30: 72 72 65 6e 74 20 73 65 72 76 65 72 20 69 73 20 rrent server is
ac40: 6e 6f 74 20 79 65 74 20 61 6c 69 76 65 20 61 6e not yet alive an
ac50: 64 20 63 61 6e 6e 6f 74 20 70 69 6e 67 20 69 74 d cannot ping it
ac60: 73 65 6c 66 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 self.;;; ;;.;;;
ac70: 28 64 65 66 69 6e 65 20 28 75 70 64 61 74 65 2d (define (update-
ac80: 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 20 61 63 known-servers ac
ac90: 66 67 29 0a 3b 3b 3b 20 20 20 3b 3b 20 72 65 61 fg).;;; ;; rea
aca0: 64 6c 6c 20 61 6c 6c 20 70 6b 74 73 0a 3b 3b 3b dll all pkts.;;;
acb0: 20 20 20 3b 3b 20 66 6f 72 65 61 63 68 20 70 6b ;; foreach pk
acc0: 74 3b 20 69 66 20 69 74 20 69 73 6e 27 74 20 6d t; if it isn't m
acd0: 65 20 70 69 6e 67 20 74 68 65 20 73 65 72 76 65 e ping the serve
ace0: 72 3b 20 69 66 20 61 6c 69 76 65 2c 20 61 64 64 r; if alive, add
acf0: 20 74 6f 20 68 6f 73 74 73 20 68 61 73 68 2c 20 to hosts hash,
ad00: 65 6c 73 65 20 72 6d 20 74 68 65 20 70 6b 74 0a else rm the pkt.
ad10: 3b 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 73 74 ;;; (let* ((st
ad20: 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e art-time (curren
ad30: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 t-milliseconds))
ad40: 0a 3b 3b 3b 20 09 20 28 61 6c 6c 2d 70 6b 74 73 .;;; . (all-pkts
ad50: 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 (delete-duplic
ad60: 61 74 65 73 0a 3b 3b 3b 20 09 09 20 20 20 20 20 ates.;;; ..
ad70: 28 61 70 70 65 6e 64 20 28 67 65 74 2d 61 6c 6c (append (get-all
ad80: 2d 73 65 72 76 65 72 2d 70 6b 74 73 20 61 63 66 -server-pkts acf
ad90: 67 29 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 g).;;; ... (
ada0: 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 hash-table-value
adb0: 73 20 28 61 72 65 61 2d 68 6f 73 74 73 20 61 63 s (area-hosts ac
adc0: 66 67 29 29 29 29 29 0a 3b 3b 3b 20 09 20 28 68 fg))))).;;; . (h
add0: 6f 73 74 73 68 61 73 68 20 28 61 72 65 61 2d 68 ostshash (area-h
ade0: 6f 73 74 73 20 61 63 66 67 29 29 0a 3b 3b 3b 20 osts acfg)).;;;
adf0: 09 20 28 6d 79 2d 69 64 20 20 20 20 20 28 61 72 . (my-id (ar
ae00: 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 29 0a ea-pktid acfg)).
ae10: 3b 3b 3b 20 09 20 28 70 6b 74 73 64 69 72 20 20 ;;; . (pktsdir
ae20: 20 28 61 72 65 61 2d 70 6b 74 73 64 69 72 20 61 (area-pktsdir a
ae30: 63 66 67 29 29 20 3b 3b 20 6e 65 65 64 65 64 20 cfg)) ;; needed
ae40: 74 6f 20 72 65 6d 6f 76 65 20 70 6b 74 73 20 66 to remove pkts f
ae50: 72 6f 6d 20 6e 6f 6e 2d 72 65 73 70 6f 6e 73 69 rom non-responsi
ae60: 76 65 20 73 65 72 76 65 72 73 0a 3b 3b 3b 20 09 ve servers.;;; .
ae70: 20 28 6e 75 6d 73 72 76 73 20 20 20 30 29 0a 3b (numsrvs 0).;
ae80: 3b 3b 20 09 20 28 64 65 6c 70 6b 74 20 20 20 20 ;; . (delpkt
ae90: 28 6c 61 6d 62 64 61 20 28 70 6b 74 73 64 69 72 (lambda (pktsdir
aea0: 20 73 69 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 sid).;;; ..
aeb0: 20 20 28 70 72 69 6e 74 20 22 63 6c 65 61 72 69 (print "cleari
aec0: 6e 67 20 6f 75 74 20 73 65 72 76 65 72 20 22 20 ng out server "
aed0: 73 69 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 sid).;;; ..
aee0: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 28 (delete-file* (
aef0: 63 6f 6e 63 20 70 6b 74 73 64 69 72 20 22 2f 22 conc pktsdir "/"
af00: 20 73 69 64 20 22 2e 70 6b 74 22 29 29 0a 3b 3b sid ".pkt")).;;
af10: 3b 20 09 09 20 20 20 20 20 20 28 68 61 73 68 2d ; .. (hash-
af20: 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 6f table-delete! ho
af30: 73 74 73 68 61 73 68 20 73 69 64 29 29 29 29 0a stshash sid)))).
af40: 3b 3b 3b 20 20 20 20 20 28 61 72 65 61 2d 6c 61 ;;; (area-la
af50: 73 74 2d 73 72 76 75 70 2d 73 65 74 21 20 61 63 st-srvup-set! ac
af60: 66 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f fg (current-seco
af70: 6e 64 73 29 29 0a 3b 3b 3b 20 20 20 20 20 28 66 nds)).;;; (f
af80: 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 20 20 20 20 or-each.;;;
af90: 20 28 6c 61 6d 62 64 61 20 28 73 65 72 76 70 6b (lambda (servpk
afa0: 74 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 28 69 t).;;; (i
afb0: 66 20 28 6c 69 73 74 3f 20 73 65 72 76 70 6b 74 f (list? servpkt
afc0: 29 0a 3b 3b 3b 20 09 20 20 20 3b 3b 20 28 70 70 ).;;; . ;; (pp
afd0: 20 73 65 72 76 70 6b 74 29 0a 3b 3b 3b 20 09 20 servpkt).;;; .
afe0: 20 20 28 6c 65 74 2a 20 28 28 73 68 6f 73 74 20 (let* ((shost
aff0: 28 61 6c 69 73 74 2d 72 65 66 20 27 69 70 61 64 (alist-ref 'ipad
b000: 64 72 20 73 65 72 76 70 6b 74 29 29 0a 3b 3b 3b dr servpkt)).;;;
b010: 20 09 09 20 20 28 73 70 6f 72 74 20 28 61 6e 79 .. (sport (any
b020: 2d 3e 6e 75 6d 62 65 72 20 28 61 6c 69 73 74 2d ->number (alist-
b030: 72 65 66 20 27 70 6f 72 74 20 73 65 72 76 70 6b ref 'port servpk
b040: 74 29 29 29 0a 3b 3b 3b 20 09 09 20 20 28 72 65 t))).;;; .. (re
b050: 73 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 s (handle-exce
b060: 70 74 69 6f 6e 73 0a 3b 3b 3b 20 09 09 09 20 20 ptions.;;; ...
b070: 65 78 6e 0a 3b 3b 3b 20 09 09 09 20 20 28 62 65 exn.;;; ... (be
b080: 67 69 6e 0a 3b 3b 3b 20 09 09 09 20 20 20 20 3b gin.;;; ... ;
b090: 3b 20 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a 20 ; (print "INFO:
b0a0: 62 61 64 20 73 65 72 76 65 72 20 6f 6e 20 22 20 bad server on "
b0b0: 73 68 6f 73 74 20 22 3a 22 20 73 70 6f 72 74 29 shost ":" sport)
b0c0: 0a 3b 3b 3b 20 09 09 09 20 20 20 20 23 66 29 0a .;;; ... #f).
b0d0: 3b 3b 3b 20 09 09 09 20 20 28 70 69 6e 67 20 61 ;;; ... (ping a
b0e0: 63 66 67 20 73 68 6f 73 74 20 73 70 6f 72 74 29 cfg shost sport)
b0f0: 29 29 0a 3b 3b 3b 20 09 09 20 20 28 73 69 64 20 )).;;; .. (sid
b100: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 5a 20 (alist-ref 'Z
b110: 73 65 72 76 70 6b 74 29 29 20 3b 3b 20 5a 20 63 servpkt)) ;; Z c
b120: 6f 64 65 20 69 73 20 6f 75 72 20 6e 61 6d 65 20 ode is our name
b130: 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 0a 3b for the server.;
b140: 3b 3b 20 09 09 20 20 28 75 72 6c 20 20 20 28 63 ;; .. (url (c
b150: 6f 6e 63 20 73 68 6f 73 74 20 22 3a 22 20 73 70 onc shost ":" sp
b160: 6f 72 74 29 29 0a 3b 3b 3b 20 09 09 20 20 29 0a ort)).;;; .. ).
b170: 3b 3b 3b 20 09 20 20 20 20 20 23 3b 28 69 66 20 ;;; . #;(if
b180: 28 6f 72 20 28 6e 6f 74 20 72 65 73 29 0a 3b 3b (or (not res).;;
b190: 3b 20 09 09 20 20 20 20 20 28 6e 75 6c 6c 3f 20 ; .. (null?
b1a0: 72 65 73 29 29 0a 3b 3b 3b 20 09 09 20 28 62 65 res)).;;; .. (be
b1b0: 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 28 70 72 gin.;;; .. (pr
b1c0: 69 6e 74 20 22 53 54 52 41 4e 47 45 3a 20 70 69 int "STRANGE: pi
b1d0: 6e 67 20 6f 66 20 22 20 75 72 6c 20 22 20 67 61 ng of " url " ga
b1e0: 76 65 20 22 20 72 65 73 29 29 29 0a 3b 3b 3b 20 ve " res))).;;;
b1f0: 09 20 20 20 20 20 0a 3b 3b 3b 20 09 20 20 20 20 . .;;; .
b200: 20 3b 3b 20 28 70 72 69 6e 74 20 22 47 6f 74 20 ;; (print "Got
b210: 22 20 72 65 73 20 22 20 66 72 6f 6d 20 22 20 73 " res " from " s
b220: 68 6f 73 74 20 22 3a 22 20 73 70 6f 72 74 29 0a host ":" sport).
b230: 3b 3b 3b 20 09 20 20 20 20 20 28 6d 61 74 63 68 ;;; . (match
b240: 20 72 65 73 0a 3b 3b 3b 20 09 09 20 20 20 20 28 res.;;; .. (
b250: 28 71 64 75 72 61 74 69 6f 6e 20 2e 20 70 61 79 (qduration . pay
b260: 6c 6f 61 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 load).;;; ..
b270: 20 3b 3b 20 28 70 72 69 6e 74 20 22 53 65 72 76 ;; (print "Serv
b280: 65 72 20 70 6b 74 3a 22 20 28 61 6c 69 73 74 2d er pkt:" (alist-
b290: 72 65 66 20 27 69 70 61 64 64 72 20 73 65 72 76 ref 'ipaddr serv
b2a0: 70 6b 74 29 20 22 3a 22 20 28 61 6c 69 73 74 2d pkt) ":" (alist-
b2b0: 72 65 66 20 27 70 6f 72 74 20 73 65 72 76 70 6b ref 'port servpk
b2c0: 74 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b 3b t).;;; .. ;;
b2d0: 20 20 20 20 20 20 20 20 28 69 66 20 70 61 79 6c (if payl
b2e0: 6f 61 64 0a 3b 3b 3b 20 09 09 20 20 20 20 20 3b oad.;;; .. ;
b2f0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 22 53 75 ; "Su
b300: 63 63 65 73 73 22 20 22 46 61 69 6c 22 29 29 0a ccess" "Fail")).
b310: 3b 3b 3b 20 09 09 20 20 20 20 20 28 6d 61 74 63 ;;; .. (matc
b320: 68 20 70 61 79 6c 6f 61 64 0a 3b 3b 3b 20 09 09 h payload.;;; ..
b330: 09 20 20 20 20 28 28 68 6f 73 74 20 70 6f 72 74 . ((host port
b340: 20 73 74 61 74 73 29 0a 3b 3b 3b 20 09 09 09 20 stats).;;; ...
b350: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 46 ;; (print "F
b360: 72 6f 6d 20 22 20 68 6f 73 74 20 22 3a 22 20 70 rom " host ":" p
b370: 6f 72 74 20 22 20 67 6f 74 20 73 74 61 74 73 3a ort " got stats:
b380: 20 22 20 73 74 61 74 73 29 0a 3b 3b 3b 20 09 09 " stats).;;; ..
b390: 09 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 68 . (if (and h
b3a0: 6f 73 74 20 70 6f 72 74 20 73 74 61 74 73 29 0a ost port stats).
b3b0: 3b 3b 3b 20 09 09 09 09 20 28 6c 65 74 20 28 28 ;;; .... (let ((
b3c0: 75 72 6c 20 28 63 6f 6e 63 20 68 6f 73 74 20 22 url (conc host "
b3d0: 3a 22 20 70 6f 72 74 29 29 29 0a 3b 3b 3b 20 09 :" port))).;;; .
b3e0: 09 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ... (hash-tabl
b3f0: 65 2d 73 65 74 21 20 68 6f 73 74 73 68 61 73 68 e-set! hostshash
b400: 20 73 69 64 20 73 65 72 76 70 6b 74 29 0a 3b 3b sid servpkt).;;
b410: 3b 20 09 09 09 09 20 20 20 3b 3b 20 73 74 6f 72 ; .... ;; stor
b420: 65 20 62 61 73 65 64 20 6f 6e 20 68 6f 73 74 3a e based on host:
b430: 70 6f 72 74 0a 3b 3b 3b 20 09 09 09 09 20 20 20 port.;;; ....
b440: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
b450: 20 28 61 72 65 61 2d 68 6f 73 74 73 74 61 74 73 (area-hoststats
b460: 20 61 63 66 67 29 20 73 69 64 20 73 74 61 74 73 acfg) sid stats
b470: 29 29 0a 3b 3b 3b 20 09 09 09 09 20 28 70 72 69 )).;;; .... (pri
b480: 6e 74 20 22 6d 69 73 73 69 6e 67 20 64 61 74 61 nt "missing data
b490: 20 66 72 6f 6d 20 74 68 65 20 73 65 72 76 65 72 from the server
b4a0: 2c 20 6e 6f 74 20 73 75 72 65 20 77 68 61 74 20 , not sure what
b4b0: 74 68 61 74 20 6d 65 61 6e 73 21 22 29 29 0a 3b that means!")).;
b4c0: 3b 3b 20 09 09 09 20 20 20 20 20 28 73 65 74 21 ;; ... (set!
b4d0: 20 6e 75 6d 73 72 76 73 20 28 2b 20 6e 75 6d 73 numsrvs (+ nums
b4e0: 72 76 73 20 31 29 29 29 0a 3b 3b 3b 20 09 09 09 rvs 1))).;;; ...
b4f0: 20 20 20 20 28 23 66 0a 3b 3b 3b 20 09 09 09 20 (#f.;;; ...
b500: 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 6d 6f (print "Remo
b510: 76 69 6e 67 20 70 6b 74 20 22 20 73 69 64 20 22 ving pkt " sid "
b520: 20 64 75 65 20 74 6f 20 23 66 20 66 72 6f 6d 20 due to #f from
b530: 73 65 72 76 65 72 20 6f 72 20 66 61 69 6c 65 64 server or failed
b540: 20 70 69 6e 67 22 29 0a 3b 3b 3b 20 09 09 09 20 ping").;;; ...
b550: 20 20 20 20 28 64 65 6c 70 6b 74 20 70 6b 74 73 (delpkt pkts
b560: 64 69 72 20 73 69 64 29 29 0a 3b 3b 3b 20 09 09 dir sid)).;;; ..
b570: 09 20 20 20 20 28 65 6c 73 65 0a 3b 3b 3b 20 09 . (else.;;; .
b580: 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 47 .. (print "G
b590: 6f 74 20 22 29 28 70 70 20 72 65 73 29 28 70 72 ot ")(pp res)(pr
b5a0: 69 6e 74 20 22 20 66 72 6f 6d 20 73 65 72 76 65 int " from serve
b5b0: 72 20 22 29 28 70 70 20 73 65 72 76 70 6b 74 29 r ")(pp servpkt)
b5c0: 20 22 20 62 75 74 20 72 65 73 70 6f 6e 73 65 20 " but response
b5d0: 64 69 64 20 6e 6f 74 20 6d 61 74 63 68 20 28 23 did not match (#
b5e0: 66 2f 23 74 20 2e 20 6d 73 67 29 22 29 29 29 0a f/#t . msg)"))).
b5f0: 3b 3b 3b 20 09 09 20 20 20 20 28 65 6c 73 65 0a ;;; .. (else.
b600: 3b 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 68 65 ;;; .. ;; he
b610: 72 65 20 77 65 20 64 65 6c 65 74 65 20 74 68 65 re we delete the
b620: 20 70 6b 74 20 2d 20 63 61 6e 27 74 20 72 65 61 pkt - can't rea
b630: 63 68 20 74 68 65 20 73 65 72 76 65 72 2c 20 72 ch the server, r
b640: 65 6d 6f 76 65 20 69 74 0a 3b 3b 3b 20 09 09 20 emove it.;;; ..
b650: 20 20 20 20 3b 3b 20 68 6f 77 65 76 65 72 20 74 ;; however t
b660: 68 69 73 20 6c 6f 67 69 63 20 69 73 20 69 6e 61 his logic is ina
b670: 64 65 71 75 61 74 65 2e 20 77 65 20 73 68 6f 75 dequate. we shou
b680: 6c 64 20 6d 61 72 6b 20 74 68 65 20 73 65 72 76 ld mark the serv
b690: 65 72 20 61 73 20 63 68 65 63 6b 65 64 0a 3b 3b er as checked.;;
b6a0: 3b 20 09 09 20 20 20 20 20 3b 3b 20 61 6e 64 20 ; .. ;; and
b6b0: 6e 6f 74 20 67 6f 6f 64 2c 20 69 66 20 69 74 20 not good, if it
b6c0: 68 61 70 70 65 6e 73 20 61 20 73 65 63 6f 6e 64 happens a second
b6d0: 20 74 69 6d 65 20 2d 20 74 68 65 6e 20 72 65 6d time - then rem
b6e0: 6f 76 65 20 74 68 65 20 70 6b 74 0a 3b 3b 3b 20 ove the pkt.;;;
b6f0: 09 09 20 20 20 20 20 3b 3b 20 6f 72 20 73 6f 6d .. ;; or som
b700: 65 74 68 69 6e 67 20 73 69 6d 69 6c 61 72 2e 20 ething similar.
b710: 49 2e 65 2e 20 64 6f 6e 27 74 20 62 65 20 74 6f I.e. don't be to
b720: 6f 20 71 75 69 63 6b 20 74 6f 20 61 73 73 75 6d o quick to assum
b730: 65 20 74 68 65 20 73 65 72 76 65 72 20 69 73 20 e the server is
b740: 77 65 64 67 65 64 20 6f 72 20 64 65 61 64 0a 3b wedged or dead.;
b750: 3b 3b 20 09 09 20 20 20 20 20 3b 3b 20 63 6f 75 ;; .. ;; cou
b760: 6c 64 20 62 65 20 69 74 20 69 73 20 73 69 6d 70 ld be it is simp
b770: 6c 79 20 74 6f 6f 20 62 75 73 79 20 74 6f 20 72 ly too busy to r
b780: 65 70 6c 79 0a 3b 3b 3b 20 09 09 20 20 20 20 20 eply.;;; ..
b790: 28 6c 65 74 20 28 28 62 61 64 2d 70 69 6e 67 73 (let ((bad-pings
b7a0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
b7b0: 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d 68 /default (area-h
b7c0: 65 61 6c 74 68 20 61 63 66 67 29 20 75 72 6c 20 ealth acfg) url
b7d0: 30 29 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 0))).;;; ..
b7e0: 20 20 28 69 66 20 28 3e 20 62 61 64 2d 70 69 6e (if (> bad-pin
b7f0: 67 73 20 31 29 20 3b 3b 20 74 77 6f 20 62 61 64 gs 1) ;; two bad
b800: 20 70 69 6e 67 73 20 2d 20 72 65 6d 6f 76 65 20 pings - remove
b810: 70 6b 74 0a 3b 3b 3b 20 09 09 09 20 20 20 28 62 pkt.;;; ... (b
b820: 65 67 69 6e 0a 3b 3b 3b 20 09 09 09 20 20 20 20 egin.;;; ...
b830: 20 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a 20 22 (print "INFO: "
b840: 20 62 61 64 2d 70 69 6e 67 73 20 22 20 62 61 64 bad-pings " bad
b850: 20 72 65 73 70 6f 6e 73 65 73 20 66 72 6f 6d 20 responses from
b860: 22 20 75 72 6c 20 22 2c 20 64 65 6c 65 74 69 6e " url ", deletin
b870: 67 20 70 6b 74 20 22 20 73 69 64 29 0a 3b 3b 3b g pkt " sid).;;;
b880: 20 09 09 09 20 20 20 20 20 28 64 65 6c 70 6b 74 ... (delpkt
b890: 20 70 6b 74 73 64 69 72 20 73 69 64 29 29 0a 3b pktsdir sid)).;
b8a0: 3b 3b 20 09 09 09 20 20 20 28 62 65 67 69 6e 0a ;; ... (begin.
b8b0: 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 70 72 69 ;;; ... (pri
b8c0: 6e 74 20 22 49 4e 46 4f 3a 20 22 20 62 61 64 2d nt "INFO: " bad-
b8d0: 70 69 6e 67 73 20 22 20 62 61 64 20 72 65 73 70 pings " bad resp
b8e0: 6f 6e 73 65 73 20 66 72 6f 6d 20 22 20 73 68 6f onses from " sho
b8f0: 73 74 20 22 3a 22 20 73 70 6f 72 74 20 22 20 6e st ":" sport " n
b900: 6f 74 20 64 65 6c 65 74 69 6e 67 20 70 6b 74 20 ot deleting pkt
b910: 79 65 74 22 29 0a 3b 3b 3b 20 09 09 09 20 20 20 yet").;;; ...
b920: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
b930: 74 21 20 28 61 72 65 61 2d 68 65 61 6c 74 68 20 t! (area-health
b940: 61 63 66 67 29 0a 3b 3b 3b 20 09 09 09 09 09 20 acfg).;;; .....
b950: 20 20 20 20 20 75 72 6c 0a 3b 3b 3b 20 09 09 09 url.;;; ...
b960: 09 09 20 20 20 20 20 20 28 2b 20 28 68 61 73 68 .. (+ (hash
b970: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
b980: 6c 74 20 28 61 72 65 61 2d 68 65 61 6c 74 68 20 lt (area-health
b990: 61 63 66 67 29 20 75 72 6c 20 30 29 20 31 29 29 acfg) url 0) 1))
b9a0: 0a 3b 3b 3b 20 09 09 09 20 20 20 20 20 29 29 0a .;;; ... )).
b9b0: 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 29 29 29 ;;; .. )))
b9c0: 29 0a 3b 3b 3b 20 09 20 20 20 3b 3b 20 73 65 72 ).;;; . ;; ser
b9d0: 76 70 6b 74 20 69 73 20 6e 6f 74 20 61 63 74 75 vpkt is not actu
b9e0: 61 6c 6c 79 20 61 20 70 6b 74 3f 0a 3b 3b 3b 20 ally a pkt?.;;;
b9f0: 09 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 . (begin.;;; .
ba00: 20 20 20 20 20 28 70 72 69 6e 74 20 22 42 61 64 (print "Bad
ba10: 20 70 6b 74 20 22 20 73 65 72 76 70 6b 74 29 29 pkt " servpkt))
ba20: 29 29 0a 3b 3b 3b 20 20 20 20 20 20 61 6c 6c 2d )).;;; all-
ba30: 70 6b 74 73 29 0a 3b 3b 3b 20 20 20 20 20 28 73 pkts).;;; (s
ba40: 64 62 67 3e 20 22 75 70 64 61 74 65 2d 6b 6e 6f dbg> "update-kno
ba50: 77 6e 2d 73 65 72 76 65 72 73 22 20 22 65 6e 64 wn-servers" "end
ba60: 22 20 73 74 61 72 74 2d 74 69 6d 65 20 23 66 20 " start-time #f
ba70: 23 66 20 22 20 66 6f 75 6e 64 20 22 20 6e 75 6d #f " found " num
ba80: 73 72 76 73 0a 3b 3b 3b 20 09 20 20 20 22 20 73 srvs.;;; . " s
ba90: 65 72 76 65 72 73 2c 20 70 6b 74 73 3a 20 22 20 ervers, pkts: "
baa0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 29 (map (lambda (p)
bab0: 0a 3b 3b 3b 20 09 09 09 09 20 20 20 20 20 28 61 .;;; .... (a
bac0: 6c 69 73 74 2d 72 65 66 20 27 5a 20 70 29 29 0a list-ref 'Z p)).
bad0: 3b 3b 3b 20 09 09 09 09 20 20 20 61 6c 6c 2d 70 ;;; .... all-p
bae0: 6b 74 73 29 29 0a 3b 3b 3b 20 20 20 20 20 6e 75 kts)).;;; nu
baf0: 6d 73 72 76 73 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b msrvs)).;;; .;;;
bb00: 20 28 64 65 66 73 74 72 75 63 74 20 73 72 76 73 (defstruct srvs
bb10: 74 61 74 0a 3b 3b 3b 20 20 20 28 6e 75 6d 66 69 tat.;;; (numfi
bb20: 6c 65 73 20 30 29 20 20 20 3b 3b 20 6e 75 6d 62 les 0) ;; numb
bb30: 65 72 20 6f 66 20 64 62 20 66 69 6c 65 73 20 68 er of db files h
bb40: 61 6e 64 6c 65 64 20 62 79 20 74 68 69 73 20 73 andled by this s
bb50: 65 72 76 65 72 20 2d 20 73 75 62 74 72 61 63 74 erver - subtract
bb60: 20 31 20 66 6f 72 20 74 68 65 20 64 62 20 62 65 1 for the db be
bb70: 69 6e 67 20 63 75 72 72 65 6e 74 6c 79 20 6c 6f ing currently lo
bb80: 6f 6b 65 64 20 61 74 0a 3b 3b 3b 20 20 20 28 72 oked at.;;; (r
bb90: 61 6e 64 6e 75 6d 20 20 23 66 29 20 20 3b 3b 20 andnum #f) ;;
bba0: 74 69 65 20 62 72 65 61 6b 65 72 20 6e 75 6d 62 tie breaker numb
bbb0: 65 72 20 61 73 73 69 67 6e 65 64 20 74 6f 20 62 er assigned to b
bbc0: 79 20 74 68 65 20 73 65 72 76 65 72 20 69 74 73 y the server its
bbd0: 65 6c 66 20 2d 20 61 70 70 6c 69 65 73 20 6f 6e elf - applies on
bbe0: 6c 79 20 74 6f 20 74 68 65 20 64 62 20 75 6e 64 ly to the db und
bbf0: 65 72 20 63 6f 6e 73 69 64 65 72 61 74 69 6f 6e er consideration
bc00: 0a 3b 3b 3b 20 20 20 28 70 6b 74 20 20 20 20 20 .;;; (pkt
bc10: 20 23 66 29 29 20 3b 3b 20 74 68 65 20 73 65 72 #f)) ;; the ser
bc20: 76 65 72 20 70 6b 74 0a 3b 3b 3b 20 0a 3b 3b 3b ver pkt.;;; .;;;
bc30: 20 3b 3b 28 64 65 66 69 6e 65 20 28 73 72 76 2d ;;(define (srv-
bc40: 3e 73 72 76 73 74 61 74 20 73 72 76 70 6b 74 29 >srvstat srvpkt)
bc50: 0a 3b 3b 3b 20 20 20 0a 3b 3b 3b 20 3b 3b 20 47 .;;; .;;; ;; G
bc60: 65 74 20 74 68 65 20 73 65 72 76 65 72 20 62 65 et the server be
bc70: 73 74 20 66 6f 72 20 67 69 76 65 6e 20 64 62 6e st for given dbn
bc80: 61 6d 65 20 61 6e 64 20 6b 65 79 0a 3b 3b 3b 20 ame and key.;;;
bc90: 3b 3b 0a 3b 3b 3b 20 3b 3b 20 20 20 4e 4f 54 45 ;;.;;; ;; NOTE
bca0: 3a 20 6b 65 79 20 69 73 20 6e 6f 74 20 63 75 72 : key is not cur
bcb0: 72 65 6e 74 6c 79 20 75 73 65 64 2e 20 54 68 65 rently used. The
bcc0: 20 6b 65 79 20 70 6f 69 6e 74 73 20 74 6f 20 74 key points to t
bcd0: 68 65 20 6b 69 6e 64 20 6f 66 20 71 75 65 72 79 he kind of query
bce0: 2c 20 74 68 69 73 20 6d 61 79 20 62 65 20 75 73 , this may be us
bcf0: 65 66 75 6c 20 66 6f 72 20 64 69 72 65 63 74 69 eful for directi
bd00: 6e 67 20 72 65 61 64 2d 6f 6e 6c 79 20 71 75 65 ng read-only que
bd10: 72 69 65 73 2e 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b ries..;;; ;;.;;;
bd20: 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d 62 65 (define (get-be
bd30: 73 74 2d 73 65 72 76 65 72 20 61 63 66 67 20 64 st-server acfg d
bd40: 62 6e 61 6d 65 20 6b 65 79 29 0a 3b 3b 3b 20 20 bname key).;;;
bd50: 20 28 6c 65 74 2a 20 28 3b 3b 20 28 73 65 72 76 (let* (;; (serv
bd60: 65 72 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ers (hash-table-
bd70: 76 61 6c 75 65 73 20 28 61 72 65 61 2d 68 6f 73 values (area-hos
bd80: 74 73 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 09 ts acfg))).;;; .
bd90: 20 28 73 65 72 76 65 72 73 20 20 20 20 20 28 61 (servers (a
bda0: 72 65 61 2d 68 6f 73 74 73 20 61 63 66 67 29 29 rea-hosts acfg))
bdb0: 0a 3b 3b 3b 20 09 20 28 73 6b 65 79 73 20 20 20 .;;; . (skeys
bdc0: 20 20 20 20 28 73 6f 72 74 20 28 68 61 73 68 2d (sort (hash-
bdd0: 74 61 62 6c 65 2d 6b 65 79 73 20 73 65 72 76 65 table-keys serve
bde0: 72 73 29 20 73 74 72 69 6e 67 3e 3d 3f 29 29 20 rs) string>=?))
bdf0: 3b 3b 20 61 20 73 74 61 62 6c 65 20 6c 69 73 74 ;; a stable list
be00: 69 6e 67 0a 3b 3b 3b 20 09 20 28 73 74 61 72 74 ing.;;; . (start
be10: 2d 74 69 6d 65 20 20 28 63 75 72 72 65 6e 74 2d -time (current-
be20: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b milliseconds)).;
be30: 3b 3b 20 09 20 28 73 72 76 73 74 61 74 73 20 20 ;; . (srvstats
be40: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
be50: 6c 65 29 29 20 20 3b 3b 20 73 72 76 69 64 20 3d le)) ;; srvid =
be60: 3e 20 73 72 76 73 74 61 74 0a 3b 3b 3b 20 09 20 > srvstat.;;; .
be70: 28 75 72 6c 20 20 20 20 20 20 20 20 20 28 63 6f (url (co
be80: 6e 63 20 28 61 72 65 61 2d 6d 79 61 64 64 72 20 nc (area-myaddr
be90: 61 63 66 67 29 20 22 3a 22 20 28 61 72 65 61 2d acfg) ":" (area-
bea0: 70 6f 72 74 20 61 63 66 67 29 29 29 29 0a 3b 3b port acfg)))).;;
beb0: 3b 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ; ;; (print
bec0: 22 73 63 6f 72 65 73 20 66 6f 72 20 22 20 64 62 "scores for " db
bed0: 6e 61 6d 65 20 22 3a 20 22 20 28 6d 61 70 20 28 name ": " (map (
bee0: 6c 61 6d 62 64 61 20 28 6b 29 28 63 6f 6e 73 20 lambda (k)(cons
bef0: 6b 20 28 63 61 6c 63 2d 73 65 72 76 65 72 2d 73 k (calc-server-s
bf00: 63 6f 72 65 20 61 63 66 67 20 64 62 6e 61 6d 65 core acfg dbname
bf10: 20 6b 29 29 29 20 73 6b 65 79 73 29 29 0a 3b 3b k))) skeys)).;;
bf20: 3b 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ; (if (null?
bf30: 20 73 6b 65 79 73 29 0a 3b 3b 3b 20 09 28 69 66 skeys).;;; .(if
bf40: 20 28 3e 20 28 75 70 64 61 74 65 2d 6b 6e 6f 77 (> (update-know
bf50: 6e 2d 73 65 72 76 65 72 73 20 61 63 66 67 29 20 n-servers acfg)
bf60: 30 29 0a 3b 3b 3b 20 09 20 20 20 20 28 67 65 74 0).;;; . (get
bf70: 2d 62 65 73 74 2d 73 65 72 76 65 72 20 61 63 66 -best-server acf
bf80: 67 20 64 62 6e 61 6d 65 20 6b 65 79 29 20 3b 3b g dbname key) ;;
bf90: 20 73 6f 6d 65 20 72 69 73 6b 20 6f 66 20 69 6e some risk of in
bfa0: 66 69 6e 69 74 65 20 6c 6f 6f 70 20 68 65 72 65 finite loop here
bfb0: 2c 20 54 4f 44 4f 20 61 64 64 20 74 72 79 20 63 , TODO add try c
bfc0: 6f 75 6e 74 65 72 0a 3b 3b 3b 20 09 20 20 20 20 ounter.;;; .
bfd0: 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 20 20 (begin.;;; .
bfe0: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
bff0: 20 6e 6f 20 73 65 72 76 65 72 20 66 6f 75 6e 64 no server found
c000: 21 22 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 69 !") ;; since thi
c010: 73 20 70 72 6f 63 65 73 73 20 69 73 20 61 6c 73 s process is als
c020: 6f 20 61 20 73 65 72 76 65 72 20 74 68 69 73 20 o a server this
c030: 73 68 6f 75 6c 64 20 6e 65 76 65 72 20 68 61 70 should never hap
c040: 70 65 6e 0a 3b 3b 3b 20 09 20 20 20 20 20 20 23 pen.;;; . #
c050: 66 29 29 0a 3b 3b 3b 20 09 28 62 65 67 69 6e 0a f)).;;; .(begin.
c060: 3b 3b 3b 20 09 20 20 3b 3b 20 28 70 72 69 6e 74 ;;; . ;; (print
c070: 20 22 69 6e 20 67 65 74 2d 62 65 73 74 2d 73 65 "in get-best-se
c080: 72 76 65 72 20 77 69 74 68 20 73 6b 65 79 73 3d rver with skeys=
c090: 22 20 73 6b 65 79 73 29 0a 3b 3b 3b 20 09 20 20 " skeys).;;; .
c0a0: 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 (if (> (- (curre
c0b0: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 61 72 65 nt-seconds) (are
c0c0: 61 2d 6c 61 73 74 2d 73 72 76 75 70 20 61 63 66 a-last-srvup acf
c0d0: 67 29 29 20 31 30 29 0a 3b 3b 3b 20 09 20 20 20 g)) 10).;;; .
c0e0: 20 20 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 (begin.;;; ..
c0f0: 28 75 70 64 61 74 65 2d 6b 6e 6f 77 6e 2d 73 65 (update-known-se
c100: 72 76 65 72 73 20 61 63 66 67 29 0a 3b 3b 3b 20 rvers acfg).;;;
c110: 09 09 28 73 64 62 67 3e 20 22 67 65 74 2d 62 65 ..(sdbg> "get-be
c120: 73 74 2d 73 65 72 76 65 72 22 20 22 75 70 64 61 st-server" "upda
c130: 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 te-known-servers
c140: 22 20 73 74 61 72 74 2d 74 69 6d 65 20 23 66 20 " start-time #f
c150: 23 66 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 09 #f))).;;; .;;; .
c160: 20 20 3b 3b 20 66 6f 72 20 65 61 63 68 20 73 65 ;; for each se
c170: 72 76 65 72 20 6c 6f 6f 6b 20 61 74 20 74 68 65 rver look at the
c180: 20 6c 69 73 74 20 6f 66 20 64 62 66 69 6c 65 73 list of dbfiles
c190: 2c 20 74 6f 74 61 6c 20 6e 75 6d 62 65 72 20 6f , total number o
c1a0: 66 20 64 62 73 20 62 65 69 6e 67 20 68 61 6e 64 f dbs being hand
c1b0: 6c 65 64 0a 3b 3b 3b 20 09 20 20 3b 3b 20 61 6e led.;;; . ;; an
c1c0: 64 20 74 68 65 20 72 61 6e 64 20 6e 75 6d 62 65 d the rand numbe
c1d0: 72 2c 20 73 61 76 65 20 74 68 65 20 62 65 73 74 r, save the best
c1e0: 20 68 6f 73 74 0a 3b 3b 3b 20 09 20 20 3b 3b 20 host.;;; . ;;
c1f0: 61 6c 73 6f 20 64 6f 20 61 20 64 65 6c 69 73 74 also do a delist
c200: 2d 64 62 20 66 6f 72 20 65 61 63 68 20 73 65 72 -db for each ser
c210: 76 65 72 20 64 62 66 69 6c 65 20 6e 6f 74 20 75 ver dbfile not u
c220: 73 65 64 0a 3b 3b 3b 20 09 20 20 28 6c 65 74 2a sed.;;; . (let*
c230: 20 28 28 62 65 73 74 2d 73 65 72 76 65 72 20 20 ((best-server
c240: 20 20 20 20 20 23 66 29 0a 3b 3b 3b 20 09 09 20 #f).;;; ..
c250: 28 73 65 72 76 65 72 73 2d 74 6f 2d 64 65 6c 69 (servers-to-deli
c260: 73 74 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 st (make-hash-ta
c270: 62 6c 65 29 29 29 0a 3b 3b 3b 20 09 20 20 20 20 ble))).;;; .
c280: 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 3b 20 09 20 (for-each.;;; .
c290: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 72 76 (lambda (srv
c2a0: 69 64 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 id).;;; .
c2b0: 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 20 20 (let* ((server
c2c0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
c2d0: 66 2f 64 65 66 61 75 6c 74 20 73 65 72 76 65 72 f/default server
c2e0: 73 20 73 72 76 69 64 20 23 66 29 29 0a 3b 3b 3b s srvid #f)).;;;
c2f0: 20 09 09 20 20 20 20 20 20 28 73 74 61 74 73 20 .. (stats
c300: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
c310: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 61 72 65 ref/default (are
c320: 61 2d 68 6f 73 74 73 74 61 74 73 20 61 63 66 67 a-hoststats acfg
c330: 29 20 73 72 76 69 64 20 27 28 28 29 29 29 29 29 ) srvid '(()))))
c340: 0a 3b 3b 3b 20 09 09 20 3b 3b 20 28 70 72 69 6e .;;; .. ;; (prin
c350: 74 20 22 73 74 61 74 73 3a 20 22 20 73 74 61 74 t "stats: " stat
c360: 73 29 0a 3b 3b 3b 20 20 09 09 20 28 69 66 20 73 s).;;; .. (if s
c370: 65 72 76 65 72 0a 3b 3b 3b 20 09 09 20 20 20 20 erver.;;; ..
c380: 20 28 6c 65 74 2a 20 28 28 64 62 77 65 69 67 68 (let* ((dbweigh
c390: 74 73 20 28 63 61 72 20 73 74 61 74 73 29 29 0a ts (car stats)).
c3a0: 3b 3b 3b 20 09 09 09 20 20 20 20 28 73 72 76 6c ;;; ... (srvl
c3b0: 6f 61 64 20 20 20 28 6c 65 6e 67 74 68 20 28 66 oad (length (f
c3c0: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
c3d0: 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 64 62 )(not (equal? db
c3e0: 6e 61 6d 65 20 28 63 61 72 20 78 29 29 29 29 20 name (car x))))
c3f0: 64 62 77 65 69 67 68 74 73 29 29 29 0a 3b 3b 3b dbweights))).;;;
c400: 20 09 09 09 20 20 20 20 28 64 62 72 65 63 20 20 ... (dbrec
c410: 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 64 62 (alist-ref db
c420: 6e 61 6d 65 20 64 62 77 65 69 67 68 74 73 20 65 name dbweights e
c430: 71 75 61 6c 3f 29 29 20 20 3b 3b 20 67 65 74 20 qual?)) ;; get
c440: 74 68 65 20 70 61 69 72 20 77 69 74 68 20 66 6e the pair with fn
c450: 61 6d 65 20 2e 20 72 61 6e 64 73 63 6f 72 65 0a ame . randscore.
c460: 3b 3b 3b 20 09 09 09 20 20 20 20 28 72 61 6e 64 ;;; ... (rand
c470: 6e 75 6d 20 20 20 28 69 66 20 64 62 72 65 63 0a num (if dbrec.
c480: 3b 3b 3b 20 09 09 09 09 09 20 20 20 64 62 72 65 ;;; ..... dbre
c490: 63 20 3b 3b 20 28 63 64 72 20 64 62 72 65 63 29 c ;; (cdr dbrec)
c4a0: 0a 3b 3b 3b 20 09 09 09 09 09 20 20 20 30 29 29 .;;; ..... 0))
c4b0: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 28 ).;;; .. (
c4c0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
c4d0: 73 72 76 73 74 61 74 73 20 73 72 76 69 64 20 28 srvstats srvid (
c4e0: 6d 61 6b 65 2d 73 72 76 73 74 61 74 20 6e 75 6d make-srvstat num
c4f0: 66 69 6c 65 73 3a 20 73 72 76 6c 6f 61 64 20 72 files: srvload r
c500: 61 6e 64 6e 75 6d 3a 20 72 61 6e 64 6e 75 6d 20 andnum: randnum
c510: 70 6b 74 3a 20 73 65 72 76 65 72 29 29 29 29 29 pkt: server)))))
c520: 29 0a 3b 3b 3b 20 09 20 20 20 20 20 73 6b 65 79 ).;;; . skey
c530: 73 29 0a 3b 3b 3b 20 09 20 20 20 20 0a 3b 3b 3b s).;;; . .;;;
c540: 20 09 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f . (let* ((so
c550: 72 74 65 64 20 20 20 20 28 73 6f 72 74 20 28 68 rted (sort (h
c560: 61 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 ash-table-values
c570: 20 73 72 76 73 74 61 74 73 29 20 0a 3b 3b 3b 20 srvstats) .;;;
c580: 09 09 09 09 20 20 20 20 28 6c 61 6d 62 64 61 20 .... (lambda
c590: 28 61 20 62 29 0a 3b 3b 3b 20 09 09 09 09 20 20 (a b).;;; ....
c5a0: 20 20 20 20 28 6c 65 74 20 28 28 6e 75 6d 66 69 (let ((numfi
c5b0: 6c 65 73 2d 61 20 28 73 72 76 73 74 61 74 2d 6e les-a (srvstat-n
c5c0: 75 6d 66 69 6c 65 73 20 61 29 29 0a 3b 3b 3b 20 umfiles a)).;;;
c5d0: 09 09 09 09 09 20 20 20 20 28 6e 75 6d 66 69 6c ..... (numfil
c5e0: 65 73 2d 62 20 28 73 72 76 73 74 61 74 2d 6e 75 es-b (srvstat-nu
c5f0: 6d 66 69 6c 65 73 20 62 29 29 0a 3b 3b 3b 20 09 mfiles b)).;;; .
c600: 09 09 09 09 20 20 20 20 28 72 61 6e 64 6e 75 6d .... (randnum
c610: 2d 61 20 20 28 73 72 76 73 74 61 74 2d 72 61 6e -a (srvstat-ran
c620: 64 6e 75 6d 20 61 29 29 0a 3b 3b 3b 20 09 09 09 dnum a)).;;; ...
c630: 09 09 20 20 20 20 28 72 61 6e 64 6e 75 6d 2d 62 .. (randnum-b
c640: 20 20 28 73 72 76 73 74 61 74 2d 72 61 6e 64 6e (srvstat-randn
c650: 75 6d 20 62 29 29 29 0a 3b 3b 3b 20 09 09 09 09 um b))).;;; ....
c660: 09 28 69 66 20 28 3c 20 6e 75 6d 66 69 6c 65 73 .(if (< numfiles
c670: 2d 61 20 6e 75 6d 66 69 6c 65 73 2d 62 29 20 3b -a numfiles-b) ;
c680: 3b 20 4e 6f 74 65 2c 20 49 20 64 6f 6e 27 74 20 ; Note, I don't
c690: 74 68 69 6e 6b 20 61 64 64 69 6e 67 20 61 6e 20 think adding an
c6a0: 6f 66 66 73 65 74 20 77 6f 72 6b 73 20 68 65 72 offset works her
c6b0: 65 2e 20 47 6f 61 6c 20 77 61 73 20 6f 6e 6c 79 e. Goal was only
c6c0: 20 6d 6f 76 65 20 66 69 6c 65 20 68 61 6e 64 6c move file handl
c6d0: 69 6e 67 20 74 6f 20 61 20 64 69 66 66 65 72 65 ing to a differe
c6e0: 6e 74 20 73 65 72 76 65 72 20 69 66 20 69 74 20 nt server if it
c6f0: 68 61 73 20 32 20 6c 65 73 73 0a 3b 3b 3b 20 09 has 2 less.;;; .
c700: 09 09 09 09 20 20 20 20 23 74 0a 3b 3b 3b 20 09 .... #t.;;; .
c710: 09 09 09 09 20 20 20 20 28 69 66 20 28 61 6e 64 .... (if (and
c720: 20 28 65 71 75 61 6c 3f 20 6e 75 6d 66 69 6c 65 (equal? numfile
c730: 73 2d 61 20 6e 75 6d 66 69 6c 65 73 2d 62 29 0a s-a numfiles-b).
c740: 3b 3b 3b 20 09 09 09 09 09 09 20 20 20 20 20 28 ;;; ...... (
c750: 3c 20 72 61 6e 64 6e 75 6d 2d 61 20 72 61 6e 64 < randnum-a rand
c760: 6e 75 6d 2d 62 29 29 0a 3b 3b 3b 20 09 09 09 09 num-b)).;;; ....
c770: 09 09 23 74 0a 3b 3b 3b 20 09 09 09 09 09 09 23 ..#t.;;; ......#
c780: 66 29 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 20 f)))))).;;; ..
c790: 20 28 62 65 73 74 20 20 20 20 20 20 28 69 66 20 (best (if
c7a0: 28 6e 75 6c 6c 3f 20 73 6f 72 74 65 64 29 0a 3b (null? sorted).;
c7b0: 3b 3b 20 09 09 09 09 20 20 28 62 65 67 69 6e 0a ;; .... (begin.
c7c0: 3b 3b 3b 20 09 09 09 09 20 20 20 20 28 70 72 69 ;;; .... (pri
c7d0: 6e 74 20 22 45 52 52 4f 52 3a 20 73 68 6f 75 6c nt "ERROR: shoul
c7e0: 64 20 6e 65 76 65 72 20 62 65 20 6e 75 6c 6c 20 d never be null
c7f0: 64 75 65 20 74 6f 20 73 65 6c 66 20 61 73 20 73 due to self as s
c800: 65 72 76 65 72 2e 22 29 0a 3b 3b 3b 20 09 09 09 erver.").;;; ...
c810: 09 20 20 20 20 23 66 29 0a 3b 3b 3b 20 09 09 09 . #f).;;; ...
c820: 09 20 20 28 73 72 76 73 74 61 74 2d 70 6b 74 20 . (srvstat-pkt
c830: 28 63 61 72 20 73 6f 72 74 65 64 29 29 29 29 29 (car sorted)))))
c840: 0a 3b 3b 3b 20 09 20 20 20 20 20 20 23 3b 28 70 .;;; . #;(p
c850: 72 69 6e 74 20 22 53 45 52 56 45 52 28 22 20 75 rint "SERVER(" u
c860: 72 6c 20 22 29 3a 20 22 20 64 62 6e 61 6d 65 20 rl "): " dbname
c870: 22 3a 20 22 20 28 6d 61 70 20 28 6c 61 6d 62 64 ": " (map (lambd
c880: 61 20 28 73 72 76 29 0a 3b 3b 3b 20 09 09 09 09 a (srv).;;; ....
c890: 09 09 09 20 20 20 20 28 6c 65 74 20 28 28 70 20 ... (let ((p
c8a0: 28 73 72 76 73 74 61 74 2d 70 6b 74 20 73 72 76 (srvstat-pkt srv
c8b0: 29 29 29 0a 3b 3b 3b 20 09 09 09 09 09 09 09 20 ))).;;; .......
c8c0: 20 20 20 20 20 28 63 6f 6e 63 20 28 61 6c 69 73 (conc (alis
c8d0: 74 2d 72 65 66 20 27 69 70 61 64 64 72 20 70 29 t-ref 'ipaddr p)
c8e0: 20 22 3a 22 20 28 61 6c 69 73 74 2d 72 65 66 20 ":" (alist-ref
c8f0: 27 70 6f 72 74 20 70 29 0a 3b 3b 3b 20 09 09 09 'port p).;;; ...
c900: 09 09 09 09 09 20 20 20 20 22 28 22 20 28 73 72 ..... "(" (sr
c910: 76 73 74 61 74 2d 6e 75 6d 66 69 6c 65 73 20 73 vstat-numfiles s
c920: 72 76 29 22 2c 22 28 73 72 76 73 74 61 74 2d 72 rv)","(srvstat-r
c930: 61 6e 64 6e 75 6d 20 73 72 76 29 22 29 22 29 29 andnum srv)")"))
c940: 29 0a 3b 3b 3b 20 09 09 09 09 09 09 09 20 20 20 ).;;; .......
c950: 20 73 6f 72 74 65 64 29 29 0a 3b 3b 3b 20 09 20 sorted)).;;; .
c960: 20 20 20 20 20 62 65 73 74 29 29 29 29 29 29 0a best)))))).
c970: 3b 3b 3b 20 20 20 20 20 0a 3b 3b 3b 20 20 20 20 ;;; .;;;
c980: 20 3b 3b 20 73 65 6e 64 20 6f 75 74 20 61 6e 20 ;; send out an
c990: 22 49 27 6d 20 61 62 6f 75 74 20 74 6f 20 65 78 "I'm about to ex
c9a0: 69 74 20 6e 6f 74 69 63 65 20 74 6f 20 61 6c 6c it notice to all
c9b0: 20 6b 6e 6f 77 6e 20 73 65 72 76 65 72 73 22 0a known servers".
c9c0: 3b 3b 3b 20 20 20 20 20 3b 3b 0a 3b 3b 3b 20 28 ;;; ;;.;;; (
c9d0: 64 65 66 69 6e 65 20 28 64 65 61 74 68 2d 69 6d define (death-im
c9e0: 6d 69 6e 65 6e 74 20 61 63 66 67 29 0a 3b 3b 3b minent acfg).;;;
c9f0: 20 20 20 27 28 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b '()).;;; .;;;
ca00: 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;=============
ca10: 3d 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 3b 20 3b 3b =========.;;; ;;
ca50: 20 55 20 4c 20 45 20 58 20 20 2d 20 20 54 20 48 U L E X - T H
ca60: 20 45 20 20 20 49 20 4e 20 54 20 45 20 52 20 45 E I N T E R E
ca70: 20 53 20 54 20 49 20 4e 20 47 20 20 20 53 20 54 S T I N G S T
ca80: 20 55 20 46 20 46 20 21 20 21 0a 3b 3b 3b 20 3b U F F ! !.;;; ;
ca90: 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cad0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b =======.;;; .;;;
cae0: 20 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 68 ;; register a h
caf0: 61 6e 64 6c 65 72 0a 3b 3b 3b 20 3b 3b 20 20 20 andler.;;; ;;
cb00: 4e 4f 54 45 53 3a 0a 3b 3b 3b 20 3b 3b 20 20 20 NOTES:.;;; ;;
cb10: 20 20 64 62 69 6e 69 74 73 71 6c 20 20 20 69 73 dbinitsql is
cb20: 20 72 65 73 65 72 76 65 64 20 66 6f 72 20 61 20 reserved for a
cb30: 6c 69 73 74 20 6f 66 20 73 71 6c 20 73 74 61 74 list of sql stat
cb40: 65 6d 65 6e 74 73 20 66 6f 72 20 69 6e 69 74 69 ements for initi
cb50: 61 6c 69 7a 69 6e 67 20 74 68 65 20 64 62 0a 3b alizing the db.;
cb60: 3b 3b 20 3b 3b 20 20 20 20 20 64 62 69 6e 69 74 ;; ;; dbinit
cb70: 66 6e 20 20 20 20 69 73 20 72 65 73 65 72 76 65 fn is reserve
cb80: 64 20 66 6f 72 20 61 20 64 62 20 69 6e 69 74 20 d for a db init
cb90: 66 75 6e 63 74 69 6f 6e 2c 20 69 66 20 65 78 69 function, if exi
cba0: 73 74 73 20 63 61 6c 6c 65 64 20 61 66 74 65 72 sts called after
cbb0: 20 64 62 69 6e 69 74 73 71 6c 0a 3b 3b 3b 20 3b dbinitsql.;;; ;
cbc0: 3b 20 20 20 20 20 0a 3b 3b 3b 20 28 64 65 66 69 ; .;;; (defi
cbd0: 6e 65 20 28 72 65 67 69 73 74 65 72 20 61 63 66 ne (register acf
cbe0: 67 20 6b 65 79 20 6f 62 6a 20 23 21 6f 70 74 69 g key obj #!opti
cbf0: 6f 6e 61 6c 20 28 63 74 79 70 65 20 27 64 62 77 onal (ctype 'dbw
cc00: 72 69 74 65 29 29 0a 3b 3b 3b 20 20 20 28 6c 65 rite)).;;; (le
cc10: 74 20 28 28 68 74 20 28 61 72 65 61 2d 72 74 61 t ((ht (area-rta
cc20: 62 6c 65 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 ble acfg))).;;;
cc30: 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 (if (hash-ta
cc40: 62 6c 65 2d 65 78 69 73 74 73 3f 20 68 74 20 6b ble-exists? ht k
cc50: 65 79 29 0a 3b 3b 3b 20 09 28 70 72 69 6e 74 20 ey).;;; .(print
cc60: 22 57 41 52 4e 49 4e 47 3a 20 72 65 64 65 66 69 "WARNING: redefi
cc70: 6e 69 74 69 6f 6e 20 6f 66 20 65 6e 74 72 79 20 nition of entry
cc80: 22 20 6b 65 79 29 29 0a 3b 3b 3b 20 20 20 20 20 " key)).;;;
cc90: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
cca0: 20 68 74 20 6b 65 79 20 28 6d 61 6b 65 2d 63 61 ht key (make-ca
ccb0: 6c 6c 64 61 74 20 6f 62 6a 3a 20 6f 62 6a 20 63 lldat obj: obj c
ccc0: 74 79 70 65 3a 20 63 74 79 70 65 29 29 29 29 0a type: ctype)))).
ccd0: 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 75 73 61 67 ;;; .;;; ;; usag
cce0: 65 3a 20 72 65 67 69 73 74 65 72 2d 62 61 74 63 e: register-batc
ccf0: 68 20 61 63 66 67 20 27 28 28 6b 65 79 31 20 2e h acfg '((key1 .
cd00: 20 73 71 6c 31 29 20 28 6b 65 79 32 20 2e 20 73 sql1) (key2 . s
cd10: 71 6c 32 29 20 2e 2e 2e 20 29 0a 3b 3b 3b 20 3b ql2) ... ).;;; ;
cd20: 3b 20 4e 42 2f 2f 20 6f 62 6a 20 69 73 20 6f 66 ; NB// obj is of
cd30: 74 65 6e 20 61 6e 20 73 71 6c 20 71 75 65 72 79 ten an sql query
cd40: 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 .;;; ;;.;;; (def
cd50: 69 6e 65 20 28 72 65 67 69 73 74 65 72 2d 62 61 ine (register-ba
cd60: 74 63 68 20 61 63 66 67 20 63 74 79 70 65 20 64 tch acfg ctype d
cd70: 61 74 61 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 20 ata).;;; (let
cd80: 28 28 68 74 20 28 61 72 65 61 2d 72 74 61 62 6c ((ht (area-rtabl
cd90: 65 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 20 20 e acfg))).;;;
cda0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
cdb0: 64 61 74 29 0a 3b 3b 3b 20 09 20 20 20 28 68 61 dat).;;; . (ha
cdc0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 sh-table-set! ht
cdd0: 20 28 63 61 72 20 64 61 74 29 28 6d 61 6b 65 2d (car dat)(make-
cde0: 63 61 6c 6c 64 61 74 20 6f 62 6a 3a 20 28 63 64 calldat obj: (cd
cdf0: 72 20 64 61 74 29 20 63 74 79 70 65 3a 20 63 74 r dat) ctype: ct
ce00: 79 70 65 29 29 29 0a 3b 3b 3b 20 09 20 64 61 74 ype))).;;; . dat
ce10: 61 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 a))).;;; .;;; (d
ce20: 65 66 69 6e 65 20 28 69 6e 69 74 69 61 6c 69 7a efine (initializ
ce30: 65 2d 61 72 65 61 2d 63 61 6c 6c 73 2d 66 72 6f e-area-calls-fro
ce40: 6d 2d 73 70 65 63 66 69 6c 65 20 61 72 65 61 20 m-specfile area
ce50: 73 70 65 63 66 69 6c 65 29 0a 3b 3b 3b 20 20 20 specfile).;;;
ce60: 28 6c 65 74 2a 20 28 28 63 61 6c 6c 73 70 65 63 (let* ((callspec
ce70: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
ce80: 6d 2d 66 69 6c 65 20 73 70 65 63 66 69 6c 65 20 m-file specfile
ce90: 72 65 61 64 20 29 29 29 0a 3b 3b 3b 20 20 20 20 read ))).;;;
cea0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
ceb0: 64 61 20 28 67 72 6f 75 70 29 0a 3b 3b 3b 20 20 da (group).;;;
cec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
ced0: 72 65 67 69 73 74 65 72 2d 62 61 74 63 68 0a 3b register-batch.;
cee0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
cef0: 20 20 20 20 61 72 65 61 0a 3b 3b 3b 20 20 20 20 area.;;;
cf00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
cf10: 61 72 20 67 72 6f 75 70 29 0a 3b 3b 3b 20 20 20 ar group).;;;
cf20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
cf30: 63 64 72 20 67 72 6f 75 70 29 29 29 0a 3b 3b 3b cdr group))).;;;
cf40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 c
cf50: 61 6c 6c 73 70 65 63 29 29 29 0a 3b 3b 3b 20 0a allspec))).;;; .
cf60: 3b 3b 3b 20 3b 3b 20 67 65 74 2d 72 65 6e 74 72 ;;; ;; get-rentr
cf70: 79 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 y.;;; ;;.;;; (de
cf80: 66 69 6e 65 20 28 67 65 74 2d 72 65 6e 74 72 79 fine (get-rentry
cf90: 20 61 63 66 67 20 6b 65 79 29 0a 3b 3b 3b 20 20 acfg key).;;;
cfa0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
cfb0: 2f 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d 72 /default (area-r
cfc0: 74 61 62 6c 65 20 61 63 66 67 29 20 6b 65 79 20 table acfg) key
cfd0: 23 66 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 #f)).;;; .;;; (d
cfe0: 65 66 69 6e 65 20 28 67 65 74 2d 72 73 71 6c 20 efine (get-rsql
cff0: 61 63 66 67 20 6b 65 79 29 0a 3b 3b 3b 20 20 20 acfg key).;;;
d000: 28 6c 65 74 20 28 28 63 64 61 74 20 28 67 65 74 (let ((cdat (get
d010: 2d 72 65 6e 74 72 79 20 61 63 66 67 20 6b 65 79 -rentry acfg key
d020: 29 29 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 20 ))).;;; (if
d030: 63 64 61 74 0a 3b 3b 3b 20 09 28 63 61 6c 6c 64 cdat.;;; .(calld
d040: 61 74 2d 6f 62 6a 20 63 64 61 74 29 0a 3b 3b 3b at-obj cdat).;;;
d050: 20 09 23 66 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b .#f))).;;; .;;;
d060: 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 62 6c .;;; .;;; ;; bl
d070: 6f 63 6b 69 6e 67 20 63 61 6c 6c 3a 0a 3b 3b 3b ocking call:.;;;
d080: 20 3b 3b 20 20 20 20 63 6c 69 65 6e 74 20 20 20 ;; client
d090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d0a0: 20 20 20 20 20 20 73 65 72 76 65 72 0a 3b 3b 3b server.;;;
d0b0: 20 3b 3b 20 20 20 20 2d 2d 2d 2d 2d 2d 20 20 20 ;; ------
d0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d0d0: 20 20 20 20 20 20 2d 2d 2d 2d 2d 2d 0a 3b 3b 3b ------.;;;
d0e0: 20 3b 3b 20 20 20 20 63 61 6c 6c 28 29 0a 3b 3b ;; call().;;
d0f0: 3b 20 3b 3b 20 20 20 20 73 65 6e 64 2d 6d 65 73 ; ;; send-mes
d100: 73 61 67 65 28 29 0a 3b 3b 3b 20 3b 3b 20 20 20 sage().;;; ;;
d110: 20 6e 6d 73 67 2d 73 65 6e 64 28 29 0a 3b 3b 3b nmsg-send().;;;
d120: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
d130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d140: 20 20 20 20 20 20 6e 6d 73 67 2d 72 65 63 65 69 nmsg-recei
d150: 76 65 28 29 0a 3b 3b 3b 20 3b 3b 20 20 20 20 20 ve().;;; ;;
d160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 6d nm
d180: 73 67 2d 72 65 73 70 6f 6e 64 28 61 63 6b 2c 63 sg-respond(ack,c
d190: 6f 6f 6b 69 65 29 0a 3b 3b 3b 20 3b 3b 20 20 20 ookie).;;; ;;
d1a0: 20 61 63 6b 2c 20 63 6f 6f 6b 69 65 0a 3b 3b 3b ack, cookie.;;;
d1b0: 20 3b 3b 20 20 20 20 6d 62 6f 78 2d 74 68 72 65 ;; mbox-thre
d1c0: 61 64 2d 77 61 69 74 28 63 6f 6f 6b 69 65 29 0a ad-wait(cookie).
d1d0: 3b 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;; ;;
d1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1f0: 20 20 20 20 20 20 20 20 20 6e 6d 73 67 2d 73 65 nmsg-se
d200: 6e 64 28 63 6c 69 65 6e 74 2c 63 6f 6f 6b 69 65 nd(client,cookie
d210: 2c 72 65 73 75 6c 74 29 0a 3b 3b 3b 20 3b 3b 20 ,result).;;; ;;
d220: 20 20 20 20 20 20 20 6e 6d 73 67 2d 72 65 73 70 nmsg-resp
d230: 6f 6e 64 28 61 63 6b 29 0a 3b 3b 3b 20 3b 3b 20 ond(ack).;;; ;;
d240: 20 20 20 20 20 20 20 72 65 74 75 72 6e 20 72 65 return re
d250: 73 75 6c 74 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 sult.;;; ;;.;;;
d260: 3b 3b 20 72 65 73 65 72 76 65 64 20 61 63 74 69 ;; reserved acti
d270: 6f 6e 3a 0a 3b 3b 3b 20 3b 3b 20 20 20 20 27 69 on:.;;; ;; 'i
d280: 6d 6d 65 64 69 61 74 65 0a 3b 3b 3b 20 3b 3b 20 mmediate.;;; ;;
d290: 20 20 20 27 64 62 69 6e 69 74 73 71 6c 0a 3b 3b 'dbinitsql.;;
d2a0: 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 ; ;;.;;; (define
d2b0: 20 28 63 61 6c 6c 20 61 63 66 67 20 64 62 6e 61 (call acfg dbna
d2c0: 6d 65 20 61 63 74 69 6f 6e 20 70 61 72 61 6d 73 me action params
d2d0: 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 63 6f 75 #!optional (cou
d2e0: 6e 74 20 30 29 29 0a 3b 3b 3b 20 20 20 28 6c 65 nt 0)).;;; (le
d2f0: 74 2a 20 28 28 63 61 6c 6c 2d 73 74 61 72 74 2d t* ((call-start-
d300: 74 69 6d 65 20 20 20 20 20 28 63 75 72 72 65 6e time (curren
d310: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 t-milliseconds))
d320: 0a 3b 3b 3b 20 09 20 28 73 72 76 20 20 20 20 20 .;;; . (srv
d330: 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 74 (get
d340: 2d 62 65 73 74 2d 73 65 72 76 65 72 20 61 63 66 -best-server acf
d350: 67 20 64 62 6e 61 6d 65 20 61 63 74 69 6f 6e 29 g dbname action)
d360: 29 0a 3b 3b 3b 20 09 20 28 70 6f 73 74 2d 67 65 ).;;; . (post-ge
d370: 74 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 t-start-time (cu
d380: 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
d390: 64 73 29 29 0a 3b 3b 3b 20 09 20 28 72 64 61 74 ds)).;;; . (rdat
d3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3b0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
d3c0: 64 65 66 61 75 6c 74 20 28 61 72 65 61 2d 72 74 default (area-rt
d3d0: 61 62 6c 65 20 61 63 66 67 29 20 61 63 74 69 6f able acfg) actio
d3e0: 6e 20 23 66 29 29 0a 3b 3b 3b 20 09 20 28 6d 79 n #f)).;;; . (my
d3f0: 69 64 20 20 20 20 20 20 20 20 20 20 20 20 20 20 id
d400: 20 20 28 74 72 69 6d 2d 70 6b 74 69 64 20 28 61 (trim-pktid (a
d410: 72 65 61 2d 70 6b 74 69 64 20 61 63 66 67 29 29 rea-pktid acfg))
d420: 29 0a 3b 3b 3b 20 09 20 28 73 72 76 69 64 20 20 ).;;; . (srvid
d430: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 72 (tr
d440: 69 6d 2d 70 6b 74 69 64 20 28 61 6c 69 73 74 2d im-pktid (alist-
d450: 72 65 66 20 27 5a 20 73 72 76 29 29 29 0a 3b 3b ref 'Z srv))).;;
d460: 3b 20 09 20 28 63 6f 6f 6b 69 65 20 20 20 20 20 ; . (cookie
d470: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 63 (make-c
d480: 6f 6f 6b 69 65 20 6d 79 69 64 29 29 29 0a 3b 3b ookie myid))).;;
d490: 3b 20 20 20 20 20 28 73 64 62 67 3e 20 22 63 61 ; (sdbg> "ca
d4a0: 6c 6c 22 20 22 67 65 74 2d 62 65 73 74 2d 73 65 ll" "get-best-se
d4b0: 72 76 65 72 22 20 63 61 6c 6c 2d 73 74 61 72 74 rver" call-start
d4c0: 2d 74 69 6d 65 20 23 66 20 63 61 6c 6c 2d 73 74 -time #f call-st
d4d0: 61 72 74 2d 74 69 6d 65 20 22 20 66 72 6f 6d 3a art-time " from:
d4e0: 20 22 20 6d 79 69 64 20 22 20 74 6f 20 73 65 72 " myid " to ser
d4f0: 76 65 72 3a 20 22 20 73 72 76 69 64 20 22 20 66 ver: " srvid " f
d500: 6f 72 20 22 20 64 62 6e 61 6d 65 20 22 20 61 63 or " dbname " ac
d510: 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 tion: " action "
d520: 20 70 61 72 61 6d 73 3a 20 22 20 70 61 72 61 6d params: " param
d530: 73 20 22 20 72 64 61 74 3a 20 22 20 72 64 61 74 s " rdat: " rdat
d540: 29 0a 3b 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 ).;;; (print
d550: 20 22 49 4e 46 4f 3a 20 63 61 6c 6c 20 74 6f 20 "INFO: call to
d560: 22 20 28 61 6c 69 73 74 2d 72 65 66 20 27 69 70 " (alist-ref 'ip
d570: 61 64 64 72 20 73 72 76 29 20 22 3a 22 20 28 61 addr srv) ":" (a
d580: 6c 69 73 74 2d 72 65 66 20 27 70 6f 72 74 20 73 list-ref 'port s
d590: 72 76 29 20 22 20 66 72 6f 6d 20 22 20 28 61 72 rv) " from " (ar
d5a0: 65 61 2d 6d 79 61 64 64 72 20 61 63 66 67 29 20 ea-myaddr acfg)
d5b0: 22 3a 22 20 28 61 72 65 61 2d 70 6f 72 74 20 61 ":" (area-port a
d5c0: 63 66 67 29 20 22 20 66 6f 72 20 22 20 64 62 6e cfg) " for " dbn
d5d0: 61 6d 65 29 0a 3b 3b 3b 20 20 20 20 20 28 69 66 ame).;;; (if
d5e0: 20 28 61 6e 64 20 73 72 76 20 72 64 61 74 29 20 (and srv rdat)
d5f0: 3b 3b 20 6e 65 65 64 20 62 6f 74 68 20 74 6f 20 ;; need both to
d600: 64 69 73 70 61 74 63 68 20 61 20 72 65 71 75 65 dispatch a reque
d610: 73 74 0a 3b 3b 3b 20 09 28 6c 65 74 2a 20 28 28 st.;;; .(let* ((
d620: 72 69 70 61 64 64 72 20 20 28 61 6c 69 73 74 2d ripaddr (alist-
d630: 72 65 66 20 27 69 70 61 64 64 72 20 73 72 76 29 ref 'ipaddr srv)
d640: 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 72 ).;;; . (r
d650: 73 72 76 69 64 20 20 20 28 61 6c 69 73 74 2d 72 srvid (alist-r
d660: 65 66 20 27 5a 20 73 72 76 29 29 0a 3b 3b 3b 20 ef 'Z srv)).;;;
d670: 09 20 20 20 20 20 20 20 28 72 70 6f 72 74 20 20 . (rport
d680: 20 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 (any->number (
d690: 61 6c 69 73 74 2d 72 65 66 20 27 70 6f 72 74 20 alist-ref 'port
d6a0: 20 20 73 72 76 29 29 29 0a 3b 3b 3b 20 09 20 20 srv))).;;; .
d6b0: 20 20 20 20 20 28 72 65 73 2d 66 75 6c 6c 20 28 (res-full (
d6c0: 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 if (and (equal?
d6d0: 72 69 70 61 64 64 72 20 28 61 72 65 61 2d 6d 79 ripaddr (area-my
d6e0: 61 64 64 72 20 61 63 66 67 29 29 0a 3b 3b 3b 20 addr acfg)).;;;
d6f0: 09 09 09 09 20 20 28 65 71 75 61 6c 3f 20 72 70 .... (equal? rp
d700: 6f 72 74 20 20 20 28 61 72 65 61 2d 70 6f 72 74 ort (area-port
d710: 20 61 63 66 67 29 29 29 0a 3b 3b 3b 20 09 09 09 acfg))).;;; ...
d720: 20 20 20 20 20 28 72 65 71 75 65 73 74 20 61 63 (request ac
d730: 66 67 20 72 69 70 61 64 64 72 20 72 70 6f 72 74 fg ripaddr rport
d740: 20 28 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 (area-pktid acf
d750: 67 29 20 61 63 74 69 6f 6e 20 63 6f 6f 6b 69 65 g) action cookie
d760: 20 64 62 6e 61 6d 65 20 70 61 72 61 6d 73 29 0a dbname params).
d770: 3b 3b 3b 20 09 09 09 20 20 20 20 20 28 73 61 66 ;;; ... (saf
d780: 65 2d 63 61 6c 6c 20 27 72 65 71 75 65 73 74 20 e-call 'request
d790: 72 69 70 61 64 64 72 20 72 70 6f 72 74 0a 3b 3b ripaddr rport.;;
d7a0: 3b 20 09 09 09 09 09 28 61 72 65 61 2d 6d 79 61 ; .....(area-mya
d7b0: 64 64 72 20 61 63 66 67 29 0a 3b 3b 3b 20 09 09 ddr acfg).;;; ..
d7c0: 09 09 09 28 61 72 65 61 2d 70 6f 72 74 20 20 20 ...(area-port
d7d0: 61 63 66 67 29 0a 3b 3b 3b 20 09 09 09 09 09 23 acfg).;;; .....#
d7e0: 3b 28 61 72 65 61 2d 70 6b 74 69 64 20 61 63 66 ;(area-pktid acf
d7f0: 67 29 0a 3b 3b 3b 20 09 09 09 09 09 72 73 72 76 g).;;; .....rsrv
d800: 69 64 0a 3b 3b 3b 20 09 09 09 09 09 61 63 74 69 id.;;; .....acti
d810: 6f 6e 20 63 6f 6f 6b 69 65 20 64 62 6e 61 6d 65 on cookie dbname
d820: 20 70 61 72 61 6d 73 29 29 29 29 0a 3b 3b 3b 20 params)))).;;;
d830: 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 65 . ;; (print "re
d840: 73 2d 66 75 6c 6c 3a 20 22 20 72 65 73 2d 66 75 s-full: " res-fu
d850: 6c 6c 29 0a 3b 3b 3b 20 09 20 20 28 6d 61 74 63 ll).;;; . (matc
d860: 68 20 72 65 73 2d 66 75 6c 6c 0a 3b 3b 3b 20 09 h res-full.;;; .
d870: 20 20 20 20 28 28 72 65 73 70 6f 6e 73 65 2d 6f ((response-o
d880: 6b 20 72 65 73 70 6f 6e 73 65 2d 6d 73 67 20 72 k response-msg r
d890: 65 6d 20 2e 2e 2e 29 0a 3b 3b 3b 20 09 20 20 20 em ...).;;; .
d8a0: 20 20 28 6c 65 74 2a 20 28 28 73 65 6e 64 2d 6d (let* ((send-m
d8b0: 65 73 73 61 67 65 2d 74 69 6d 65 20 28 63 75 72 essage-time (cur
d8c0: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
d8d0: 73 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 3b 3b s)).;;; .. ;;
d8e0: 20 28 6d 61 74 63 68 20 72 65 73 2d 66 75 6c 6c (match res-full
d8f0: 0a 3b 3b 3b 20 09 09 20 20 20 20 3b 3b 20 20 28 .;;; .. ;; (
d900: 28 72 65 73 70 6f 6e 73 65 2d 6f 6b 20 72 65 73 (response-ok res
d910: 70 6f 6e 73 65 2d 6d 73 67 29 0a 3b 3b 3b 20 09 ponse-msg).;;; .
d920: 09 20 20 20 20 3b 3b 20 28 72 65 73 70 6f 6e 73 . ;; (respons
d930: 65 2d 6f 6b 20 20 28 63 61 72 20 72 65 73 2d 66 e-ok (car res-f
d940: 75 6c 6c 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 ull)).;;; ..
d950: 3b 3b 20 28 72 65 73 70 6f 6e 73 65 2d 6d 73 67 ;; (response-msg
d960: 20 28 63 61 64 72 20 72 65 73 2d 66 75 6c 6c 29 (cadr res-full)
d970: 0a 3b 3b 3b 20 09 09 20 20 20 20 29 0a 3b 3b 3b .;;; .. ).;;;
d980: 20 09 20 20 20 20 20 20 20 3b 3b 20 28 72 65 73 . ;; (res
d990: 20 28 74 61 6b 65 20 72 65 73 2d 66 75 6c 6c 20 (take res-full
d9a0: 33 29 29 29 20 3b 3b 20 63 74 79 70 65 20 3d 3d 3))) ;; ctype ==
d9b0: 20 61 63 74 69 6f 6e 2c 20 54 4f 44 4f 3a 20 63 action, TODO: c
d9c0: 6f 6e 76 65 72 67 65 20 6f 6e 20 6f 6e 65 20 74 onverge on one t
d9d0: 65 72 6d 20 3c 3c 3d 3d 3d 20 77 68 61 74 20 77 erm <<=== what w
d9e0: 61 73 20 74 68 69 73 3f 20 42 55 47 20 0a 3b 3b as this? BUG .;;
d9f0: 3b 20 09 20 20 20 20 20 20 20 3b 3b 20 28 70 72 ; . ;; (pr
da00: 69 6e 74 20 22 75 6c 65 78 3a 63 61 6c 6c 3a 20 int "ulex:call:
da10: 73 65 6e 64 2d 6d 65 73 73 61 67 65 20 74 6f 6f send-message too
da20: 6b 20 22 20 28 2d 20 73 65 6e 64 2d 6d 65 73 73 k " (- send-mess
da30: 61 67 65 2d 74 69 6d 65 20 70 6f 73 74 2d 67 65 age-time post-ge
da40: 74 2d 73 74 61 72 74 2d 74 69 6d 65 29 20 22 20 t-start-time) "
da50: 6d 73 20 70 61 72 61 6d 73 3d 22 20 70 61 72 61 ms params=" para
da60: 6d 73 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 ms).;;; .
da70: 28 73 64 62 67 3e 20 22 63 61 6c 6c 22 20 22 73 (sdbg> "call" "s
da80: 65 6e 64 2d 6d 65 73 73 61 67 65 22 20 70 6f 73 end-message" pos
da90: 74 2d 67 65 74 2d 73 74 61 72 74 2d 74 69 6d 65 t-get-start-time
daa0: 20 23 66 20 63 61 6c 6c 2d 73 74 61 72 74 2d 74 #f call-start-t
dab0: 69 6d 65 29 0a 3b 3b 3b 20 09 20 20 20 20 20 20 ime).;;; .
dac0: 20 28 63 6f 6e 64 0a 3b 3b 3b 20 09 09 28 28 6e (cond.;;; ..((n
dad0: 6f 74 20 72 65 73 70 6f 6e 73 65 2d 6f 6b 29 20 ot response-ok)
dae0: 23 66 29 0a 3b 3b 3b 20 09 09 28 28 6d 65 6d 62 #f).;;; ..((memb
daf0: 65 72 20 72 65 73 70 6f 6e 73 65 2d 6d 73 67 20 er response-msg
db00: 27 28 22 64 62 20 72 65 61 64 20 73 75 62 6d 69 '("db read submi
db10: 74 74 65 64 22 20 22 64 62 20 77 72 69 74 65 20 tted" "db write
db20: 73 75 62 6d 69 74 74 65 64 22 29 29 0a 3b 3b 3b submitted")).;;;
db30: 20 09 09 20 28 6c 65 74 2a 20 28 28 63 6f 6f 6b .. (let* ((cook
db40: 69 65 2d 69 64 20 20 20 28 63 61 64 64 64 72 20 ie-id (cadddr
db50: 72 65 73 2d 66 75 6c 6c 29 29 0a 3b 3b 3b 20 09 res-full)).;;; .
db60: 09 09 28 6d 62 6f 78 20 20 20 20 20 20 20 20 28 ..(mbox (
db70: 6d 61 6b 65 2d 6d 61 69 6c 62 6f 78 29 29 0a 3b make-mailbox)).;
db80: 3b 3b 20 09 09 09 28 6d 62 6f 78 2d 74 69 6d 65 ;; ...(mbox-time
db90: 20 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (current-mill
dba0: 69 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 iseconds))).;;;
dbb0: 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 .. (hash-table
dbc0: 2d 73 65 74 21 20 28 61 72 65 61 2d 63 6f 6f 6b -set! (area-cook
dbd0: 69 65 32 6d 62 6f 78 20 61 63 66 67 29 20 63 6f ie2mbox acfg) co
dbe0: 6f 6b 69 65 2d 69 64 20 6d 62 6f 78 29 0a 3b 3b okie-id mbox).;;
dbf0: 3b 20 09 09 20 20 20 28 6c 65 74 2a 20 28 28 6d ; .. (let* ((m
dc00: 62 6f 78 2d 74 69 6d 65 6f 75 74 2d 73 65 63 73 box-timeout-secs
dc10: 20 20 20 20 32 30 29 0a 3b 3b 3b 20 09 09 09 20 20).;;; ...
dc20: 20 28 6d 62 6f 78 2d 74 69 6d 65 6f 75 74 2d 72 (mbox-timeout-r
dc30: 65 73 75 6c 74 20 27 4d 42 4f 58 5f 54 49 4d 45 esult 'MBOX_TIME
dc40: 4f 55 54 29 0a 3b 3b 3b 20 09 09 09 20 20 28 72 OUT).;;; ... (r
dc50: 65 73 20 20 20 20 20 20 20 20 20 20 20 20 20 20 es
dc60: 20 20 20 20 28 6d 61 69 6c 62 6f 78 2d 72 65 63 (mailbox-rec
dc70: 65 69 76 65 21 20 6d 62 6f 78 20 6d 62 6f 78 2d eive! mbox mbox-
dc80: 74 69 6d 65 6f 75 74 2d 73 65 63 73 20 6d 62 6f timeout-secs mbo
dc90: 78 2d 74 69 6d 65 6f 75 74 2d 72 65 73 75 6c 74 x-timeout-result
dca0: 29 29 0a 3b 3b 3b 20 09 09 09 20 20 28 6d 62 6f )).;;; ... (mbo
dcb0: 78 2d 72 65 63 65 69 76 65 2d 74 69 6d 65 20 20 x-receive-time
dcc0: 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 (current-milli
dcd0: 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 3b 20 09 seconds))).;;; .
dce0: 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c . (hash-tabl
dcf0: 65 2d 64 65 6c 65 74 65 21 20 28 61 72 65 61 2d e-delete! (area-
dd00: 63 6f 6f 6b 69 65 32 6d 62 6f 78 20 61 63 66 67 cookie2mbox acfg
dd10: 29 20 63 6f 6f 6b 69 65 2d 69 64 29 0a 3b 3b 3b ) cookie-id).;;;
dd20: 20 09 09 20 20 20 20 20 28 73 64 62 67 3e 20 22 .. (sdbg> "
dd30: 63 61 6c 6c 22 20 22 6d 61 69 6c 62 6f 78 2d 72 call" "mailbox-r
dd40: 65 63 65 69 76 65 22 20 6d 62 6f 78 2d 74 69 6d eceive" mbox-tim
dd50: 65 20 23 66 20 63 61 6c 6c 2d 73 74 61 72 74 2d e #f call-start-
dd60: 74 69 6d 65 20 22 20 66 72 6f 6d 3a 20 22 20 6d time " from: " m
dd70: 79 69 64 20 22 20 74 6f 20 73 65 72 76 65 72 3a yid " to server:
dd80: 20 22 20 73 72 76 69 64 20 22 20 66 6f 72 20 22 " srvid " for "
dd90: 20 64 62 6e 61 6d 65 29 0a 3b 3b 3b 20 09 09 20 dbname).;;; ..
dda0: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 75 ;; (print "u
ddb0: 6c 65 78 3a 63 61 6c 6c 20 6d 61 69 6c 62 6f 78 lex:call mailbox
ddc0: 2d 72 65 63 65 69 76 65 20 74 6f 6f 6b 20 22 20 -receive took "
ddd0: 28 2d 20 6d 62 6f 78 2d 72 65 63 65 69 76 65 2d (- mbox-receive-
dde0: 74 69 6d 65 20 6d 62 6f 78 2d 74 69 6d 65 29 20 time mbox-time)
ddf0: 22 6d 73 20 70 61 72 61 6d 73 3d 22 20 70 61 72 "ms params=" par
de00: 61 6d 73 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 ams).;;; ..
de10: 72 65 73 29 29 29 0a 3b 3b 3b 20 09 09 28 65 6c res))).;;; ..(el
de20: 73 65 0a 3b 3b 3b 20 09 09 20 28 70 72 69 6e 74 se.;;; .. (print
de30: 20 22 55 6e 68 61 6e 64 6c 65 64 20 72 65 73 70 "Unhandled resp
de40: 6f 6e 73 65 20 5c 22 22 72 65 73 70 6f 6e 73 65 onse \""response
de50: 2d 6d 73 67 22 5c 22 22 29 0a 3b 3b 3b 20 09 09 -msg"\"").;;; ..
de60: 20 23 66 29 29 0a 3b 3b 3b 20 09 20 20 20 20 20 #f)).;;; .
de70: 20 20 3b 3b 20 64 65 70 65 6e 64 69 6e 67 20 6f ;; depending o
de80: 6e 20 77 68 61 74 20 61 63 74 69 6f 6e 20 28 69 n what action (i
de90: 2e 65 2e 20 63 74 79 70 65 29 20 69 73 20 77 65 .e. ctype) is we
dea0: 20 77 69 6c 6c 20 62 6c 6f 63 6b 20 68 65 72 65 will block here
deb0: 20 77 61 69 74 69 6e 67 20 66 6f 72 0a 3b 3b 3b waiting for.;;;
dec0: 20 09 20 20 20 20 20 20 20 3b 3b 20 61 6c 6c 20 . ;; all
ded0: 74 68 65 20 64 61 74 61 20 28 6d 65 63 68 61 6e the data (mechan
dee0: 69 73 6d 20 74 6f 20 62 65 20 64 65 74 65 72 6d ism to be determ
def0: 69 6e 65 64 29 0a 3b 3b 3b 20 09 20 20 20 20 20 ined).;;; .
df00: 20 20 3b 3b 0a 3b 3b 3b 20 09 20 20 20 20 20 20 ;;.;;; .
df10: 20 3b 3b 20 69 66 20 72 65 73 20 69 73 20 61 20 ;; if res is a
df20: 22 77 6f 72 6b 69 6e 67 20 6f 6e 20 69 74 22 20 "working on it"
df30: 74 68 65 6e 20 77 61 69 74 0a 3b 3b 3b 20 09 20 then wait.;;; .
df40: 20 20 20 20 20 20 3b 3b 20 20 20 20 77 61 69 74 ;; wait
df50: 20 66 6f 72 20 72 65 73 75 6c 74 0a 3b 3b 3b 20 for result.;;;
df60: 09 20 20 20 20 20 20 20 3b 3b 20 6d 61 69 6c 62 . ;; mailb
df70: 6f 78 20 74 68 72 65 61 64 20 77 61 69 74 20 6f ox thread wait o
df80: 6e 20 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 0a n .;;; . .
df90: 3b 3b 3b 20 09 20 20 20 20 20 20 20 3b 3b 20 69 ;;; . ;; i
dfa0: 66 20 72 65 73 20 69 73 20 61 20 22 63 61 6e 27 f res is a "can'
dfb0: 74 20 68 65 6c 70 20 79 6f 75 22 20 74 68 65 6e t help you" then
dfc0: 20 74 72 79 20 61 20 64 69 66 66 65 72 65 6e 74 try a different
dfd0: 20 73 65 72 76 65 72 0a 3b 3b 3b 20 09 20 20 20 server.;;; .
dfe0: 20 20 20 20 3b 3b 20 69 66 20 72 65 73 20 69 73 ;; if res is
dff0: 20 61 20 22 61 63 6b 22 20 28 65 2e 67 2e 20 66 a "ack" (e.g. f
e000: 6f 72 20 6f 6e 65 2d 73 68 6f 74 20 72 65 71 75 or one-shot requ
e010: 65 73 74 73 29 20 74 68 65 6e 20 72 65 74 75 72 ests) then retur
e020: 6e 20 72 65 73 0a 3b 3b 3b 20 09 20 20 20 20 20 n res.;;; .
e030: 20 20 29 29 0a 3b 3b 3b 20 09 20 20 20 20 28 65 )).;;; . (e
e040: 6c 73 65 0a 3b 3b 3b 20 09 20 20 20 20 20 28 69 lse.;;; . (i
e050: 66 20 28 3c 20 63 6f 75 6e 74 20 31 30 29 0a 3b f (< count 10).;
e060: 3b 3b 20 09 09 20 28 6c 65 74 2a 20 28 28 75 72 ;; .. (let* ((ur
e070: 6c 20 28 63 6f 6e 63 20 28 61 6c 69 73 74 2d 72 l (conc (alist-r
e080: 65 66 20 27 69 70 61 64 64 72 20 73 72 76 29 20 ef 'ipaddr srv)
e090: 22 3a 22 20 28 61 6c 69 73 74 2d 72 65 66 20 27 ":" (alist-ref '
e0a0: 70 6f 72 74 20 73 72 76 29 29 29 29 0a 3b 3b 3b port srv)))).;;;
e0b0: 20 09 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c .. (thread-sl
e0c0: 65 65 70 21 20 31 29 0a 3b 3b 3b 20 09 09 20 20 eep! 1).;;; ..
e0d0: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
e0e0: 42 61 64 20 72 65 73 75 6c 74 20 66 72 6f 6d 20 Bad result from
e0f0: 22 20 75 72 6c 20 22 2c 20 64 62 6e 61 6d 65 3a " url ", dbname:
e100: 20 22 20 64 62 6e 61 6d 65 20 22 2c 20 61 63 74 " dbname ", act
e110: 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 2c ion: " action ",
e120: 20 70 61 72 61 6d 73 3a 20 22 20 70 61 72 61 6d params: " param
e130: 73 20 22 2e 20 54 72 79 69 6e 67 20 61 67 61 69 s ". Trying agai
e140: 6e 20 69 6e 20 31 20 73 65 63 6f 6e 64 2e 22 29 n in 1 second.")
e150: 0a 3b 3b 3b 20 09 09 20 20 20 28 63 61 6c 6c 20 .;;; .. (call
e160: 61 63 66 67 20 64 62 6e 61 6d 65 20 61 63 74 69 acfg dbname acti
e170: 6f 6e 20 70 61 72 61 6d 73 20 28 2b 20 63 6f 75 on params (+ cou
e180: 6e 74 20 31 29 29 29 0a 3b 3b 3b 20 09 09 20 28 nt 1))).;;; .. (
e190: 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 28 begin.;;; .. (
e1a0: 65 72 72 6f 72 20 28 63 6f 6e 63 20 22 45 52 52 error (conc "ERR
e1b0: 4f 52 3a 20 22 20 63 6f 75 6e 74 20 22 20 74 72 OR: " count " tr
e1c0: 69 65 73 2c 20 73 74 69 6c 6c 20 68 61 76 65 20 ies, still have
e1d0: 69 6d 70 72 6f 70 65 72 20 72 65 73 70 6f 6e 73 improper respons
e1e0: 65 20 72 65 73 2d 66 75 6c 6c 3d 22 20 72 65 73 e res-full=" res
e1f0: 2d 66 75 6c 6c 29 29 29 29 29 29 29 0a 3b 3b 3b -full))))))).;;;
e200: 20 09 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 20 20 .(begin.;;; .
e210: 28 69 66 20 28 6e 6f 74 20 72 64 61 74 29 0a 3b (if (not rdat).;
e220: 3b 3b 20 09 20 20 20 20 20 20 28 70 72 69 6e 74 ;; . (print
e230: 20 22 45 52 52 4f 52 3a 20 61 63 74 69 6f 6e 20 "ERROR: action
e240: 22 20 61 63 74 69 6f 6e 20 22 20 6e 6f 74 20 72 " action " not r
e250: 65 67 69 73 74 65 72 65 64 2e 22 29 0a 3b 3b 3b egistered.").;;;
e260: 20 09 20 20 20 20 20 20 28 69 66 20 28 3c 20 63 . (if (< c
e270: 6f 75 6e 74 20 31 30 29 0a 3b 3b 3b 20 09 09 20 ount 10).;;; ..
e280: 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 20 (begin.;;; ..
e290: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
e2a0: 29 0a 3b 3b 3b 20 09 09 20 20 20 28 61 72 65 61 ).;;; .. (area
e2b0: 2d 68 6f 73 74 73 2d 73 65 74 21 20 61 63 66 67 -hosts-set! acfg
e2c0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
e2d0: 65 29 29 20 3b 3b 20 63 6c 65 61 72 20 6f 75 74 e)) ;; clear out
e2e0: 20 61 6c 6c 20 6b 6e 6f 77 6e 20 68 6f 73 74 73 all known hosts
e2f0: 0a 3b 3b 3b 20 09 09 20 20 20 28 70 72 69 6e 74 .;;; .. (print
e300: 20 22 45 52 52 4f 52 3a 20 6e 6f 20 73 65 72 76 "ERROR: no serv
e310: 65 72 20 66 6f 75 6e 64 2c 20 73 72 76 3d 22 20 er found, srv="
e320: 73 72 76 20 22 2c 20 74 72 79 69 6e 67 20 61 67 srv ", trying ag
e330: 61 69 6e 20 69 6e 20 31 20 73 65 63 6f 6e 64 73 ain in 1 seconds
e340: 22 29 0a 3b 3b 3b 20 09 09 20 20 20 28 63 61 6c ").;;; .. (cal
e350: 6c 20 61 63 66 67 20 64 62 6e 61 6d 65 20 61 63 l acfg dbname ac
e360: 74 69 6f 6e 20 70 61 72 61 6d 73 20 28 2b 20 63 tion params (+ c
e370: 6f 75 6e 74 20 31 29 29 29 0a 3b 3b 3b 20 09 09 ount 1))).;;; ..
e380: 20 28 62 65 67 69 6e 0a 3b 3b 3b 20 09 09 20 20 (begin.;;; ..
e390: 20 28 65 72 72 6f 72 20 28 63 6f 6e 63 20 22 45 (error (conc "E
e3a0: 52 52 4f 52 3a 20 6e 6f 20 73 65 72 76 65 72 20 RROR: no server
e3b0: 66 6f 75 6e 64 20 61 66 74 65 72 20 31 30 20 74 found after 10 t
e3c0: 72 69 65 73 2c 20 73 72 76 3d 22 20 73 72 76 20 ries, srv=" srv
e3d0: 22 2c 20 67 69 76 69 6e 67 20 75 70 2e 22 29 29 ", giving up."))
e3e0: 0a 3b 3b 3b 20 09 09 20 20 20 23 3b 28 65 72 72 .;;; .. #;(err
e3f0: 6f 72 20 22 4e 6f 20 73 65 72 76 65 72 20 61 76 or "No server av
e400: 61 69 6c 61 62 6c 65 22 29 29 29 29 29 29 29 29 ailable"))))))))
e410: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b .;;; .;;; .;;; ;
e420: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
e430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e460: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 55 =======.;;; ;; U
e470: 20 54 20 49 20 4c 20 49 20 54 20 49 20 45 20 53 T I L I T I E S
e480: 20 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d .;;; ;;========
e490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e4a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e4b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e4c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
e4d0: 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 67 65 74 20 61 ;; .;;; ;; get a
e4e0: 20 73 69 67 6e 61 74 75 72 65 20 66 6f 72 20 69 signature for i
e4f0: 64 65 6e 74 69 66 69 6e 67 20 74 68 69 73 20 70 dentifing this p
e500: 72 6f 63 65 73 73 0a 3b 3b 3b 20 3b 3b 0a 3b 3b rocess.;;; ;;.;;
e510: 3b 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d 70 ; (define (get-p
e520: 72 6f 63 65 73 73 2d 73 69 67 6e 61 74 75 72 65 rocess-signature
e530: 29 0a 3b 3b 3b 20 20 20 28 63 6f 6e 73 20 28 67 ).;;; (cons (g
e540: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 28 63 75 et-host-name)(cu
e550: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
e560: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 3d ))).;;; .;;; ;;=
e570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5b0: 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 53 20 59 =====.;;; ;; S Y
e5c0: 20 53 20 54 20 45 20 4d 20 20 20 53 20 54 20 55 S T E M S T U
e5d0: 20 46 20 46 0a 3b 3b 3b 20 3b 3b 3d 3d 3d 3d 3d F F.;;; ;;=====
e5e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e620: 3d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 67 65 =.;;; .;;; ;; ge
e630: 74 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 t normalized cpu
e640: 20 6c 6f 61 64 20 62 79 20 72 65 61 64 69 6e 67 load by reading
e650: 20 66 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 from /proc/load
e660: 61 76 67 20 61 6e 64 0a 3b 3b 3b 20 3b 3b 20 2f avg and.;;; ;; /
e670: 70 72 6f 63 2f 63 70 75 69 6e 66 6f 20 72 65 74 proc/cpuinfo ret
e680: 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 76 61 urn all three va
e690: 6c 75 65 73 20 61 6e 64 20 74 68 65 20 6e 75 6d lues and the num
e6a0: 62 65 72 20 6f 66 20 72 65 61 6c 20 63 70 75 73 ber of real cpus
e6b0: 0a 3b 3b 3b 20 3b 3b 20 61 6e 64 20 74 68 65 20 .;;; ;; and the
e6c0: 6e 75 6d 62 65 72 20 6f 66 20 74 68 72 65 61 64 number of thread
e6d0: 73 20 72 65 74 75 72 6e 73 20 61 6c 69 73 74 20 s returns alist
e6e0: 27 28 28 61 64 6a 2d 63 70 75 2d 6c 6f 61 64 0a '((adj-cpu-load.
e6f0: 3b 3b 3b 20 3b 3b 20 2e 20 6e 6f 72 6d 61 6c 69 ;;; ;; . normali
e700: 7a 65 64 2d 70 72 6f 63 2d 6c 6f 61 64 29 20 2e zed-proc-load) .
e710: 2e 2e 20 65 74 63 2e 20 20 6b 65 79 73 3a 20 61 .. etc. keys: a
e720: 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 2c 0a 3b 3b dj-proc-load,.;;
e730: 3b 20 3b 3b 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f ; ;; adj-core-lo
e740: 61 64 2c 20 31 6d 2d 6c 6f 61 64 2c 20 35 6d 2d ad, 1m-load, 5m-
e750: 6c 6f 61 64 2c 20 31 35 6d 2d 6c 6f 61 64 0a 3b load, 15m-load.;
e760: 3b 3b 20 3b 3b 0a 3b 3b 3b 20 28 64 65 66 69 6e ;; ;;.;;; (defin
e770: 65 20 28 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 e (get-normalize
e780: 64 2d 63 70 75 2d 6c 6f 61 64 29 0a 3b 3b 3b 20 d-cpu-load).;;;
e790: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 67 65 (let ((res (ge
e7a0: 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 t-normalized-cpu
e7b0: 2d 6c 6f 61 64 2d 72 61 77 29 29 0a 3b 3b 3b 20 -load-raw)).;;;
e7c0: 09 28 64 65 66 61 75 6c 74 20 60 28 28 61 64 6a .(default `((adj
e7d0: 2d 70 72 6f 63 2d 6c 6f 61 64 20 2e 20 32 29 20 -proc-load . 2)
e7e0: 3b 3b 20 74 68 65 72 65 20 69 73 20 6e 6f 20 72 ;; there is no r
e7f0: 69 67 68 74 20 61 6e 73 77 65 72 0a 3b 3b 3b 20 ight answer.;;;
e800: 09 09 20 20 20 28 61 64 6a 2d 63 6f 72 65 2d 6c .. (adj-core-l
e810: 6f 61 64 20 2e 20 32 29 0a 3b 3b 3b 20 09 09 20 oad . 2).;;; ..
e820: 20 20 28 31 6d 2d 6c 6f 61 64 20 20 20 20 20 20 (1m-load
e830: 20 2e 20 32 29 0a 3b 3b 3b 20 09 09 20 20 20 28 . 2).;;; .. (
e840: 35 6d 2d 6c 6f 61 64 20 20 20 20 20 20 20 2e 20 5m-load .
e850: 30 29 20 3b 3b 20 63 61 75 73 65 73 20 61 20 6c 0) ;; causes a l
e860: 61 72 67 65 20 64 65 6c 74 61 20 2d 20 74 68 75 arge delta - thu
e870: 73 20 63 61 75 73 69 6e 67 20 64 65 66 61 75 6c s causing defaul
e880: 74 20 6f 66 20 74 68 72 6f 74 74 6c 69 6e 67 20 t of throttling
e890: 69 66 20 73 74 75 66 66 20 67 6f 65 73 20 77 72 if stuff goes wr
e8a0: 6f 6e 67 0a 3b 3b 3b 20 09 09 20 20 20 28 31 35 ong.;;; .. (15
e8b0: 6d 2d 6c 6f 61 64 20 20 20 20 20 20 2e 20 30 29 m-load . 0)
e8c0: 0a 3b 3b 3b 20 09 09 20 20 20 28 70 72 6f 63 20 .;;; .. (proc
e8d0: 20 20 20 20 20 20 20 20 20 2e 20 31 29 0a 3b 3b . 1).;;
e8e0: 3b 20 09 09 20 20 20 28 63 6f 72 65 20 20 20 20 ; .. (core
e8f0: 20 20 20 20 20 20 2e 20 31 29 0a 3b 3b 3b 20 09 . 1).;;; .
e900: 09 20 20 20 28 70 68 79 73 20 20 20 20 20 20 20 . (phys
e910: 20 20 20 2e 20 31 29 0a 3b 3b 3b 20 09 09 20 20 . 1).;;; ..
e920: 20 28 65 72 72 6f 72 20 20 20 20 20 20 20 20 20 (error
e930: 2e 20 23 74 29 29 29 29 0a 3b 3b 3b 20 20 20 20 . #t)))).;;;
e940: 20 28 63 6f 6e 64 0a 3b 3b 3b 20 20 20 20 20 20 (cond.;;;
e950: 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 72 65 73 ((and (list? res
e960: 29 0a 3b 3b 3b 20 09 20 20 20 28 3e 20 28 6c 65 ).;;; . (> (le
e970: 6e 67 74 68 20 72 65 73 29 20 32 29 29 0a 3b 3b ngth res) 2)).;;
e980: 3b 20 20 20 20 20 20 20 72 65 73 29 0a 3b 3b 3b ; res).;;;
e990: 20 20 20 20 20 20 28 28 65 71 3f 20 72 65 73 20 ((eq? res
e9a0: 23 66 29 20 20 20 64 65 66 61 75 6c 74 29 20 3b #f) default) ;
e9b0: 3b 20 61 64 64 20 6d 65 73 73 61 67 65 73 3f 0a ; add messages?.
e9c0: 3b 3b 3b 20 20 20 20 20 20 28 28 65 71 3f 20 72 ;;; ((eq? r
e9d0: 65 73 20 23 66 29 20 64 65 66 61 75 6c 74 29 20 es #f) default)
e9e0: 20 20 3b 3b 20 74 68 69 73 20 77 6f 75 6c 64 20 ;; this would
e9f0: 62 65 20 74 68 65 20 23 65 6f 66 0a 3b 3b 3b 20 be the #eof.;;;
ea00: 20 20 20 20 20 28 65 6c 73 65 20 64 65 66 61 75 (else defau
ea10: 6c 74 29 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 lt)))).;;; .;;;
ea20: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6e 6f 72 (define (get-nor
ea30: 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
ea40: 2d 72 61 77 29 0a 3b 3b 3b 20 20 20 28 6c 65 74 -raw).;;; (let
ea50: 2a 20 28 28 61 63 74 75 61 6c 2d 68 6f 73 74 20 * ((actual-host
ea60: 20 20 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 (get-h
ea70: 6f 73 74 2d 6e 61 6d 65 29 29 29 20 3b 3b 20 23 ost-name))) ;; #
ea80: 66 20 69 73 20 6c 6f 63 61 6c 68 6f 73 74 0a 3b f is localhost.;
ea90: 3b 3b 20 20 20 20 20 28 6c 65 74 20 28 28 64 61 ;; (let ((da
eaa0: 74 61 20 20 28 61 70 70 65 6e 64 20 0a 3b 3b 3b ta (append .;;;
eab0: 20 09 09 20 20 28 77 69 74 68 2d 69 6e 70 75 74 .. (with-input
eac0: 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f -from-file "/pro
ead0: 63 2f 6c 6f 61 64 61 76 67 22 20 72 65 61 64 2d c/loadavg" read-
eae0: 6c 69 6e 65 73 29 0a 3b 3b 3b 20 09 09 20 20 28 lines).;;; .. (
eaf0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
eb00: 66 69 6c 65 20 22 2f 70 72 6f 63 2f 63 70 75 69 file "/proc/cpui
eb10: 6e 66 6f 22 20 72 65 61 64 2d 6c 69 6e 65 73 29 nfo" read-lines)
eb20: 0a 3b 3b 3b 20 09 09 20 20 28 6c 69 73 74 20 22 .;;; .. (list "
eb30: 65 6e 64 22 29 29 29 0a 3b 3b 3b 20 09 20 20 28 end"))).;;; . (
eb40: 6c 6f 61 64 2d 72 78 20 20 28 72 65 67 65 78 70 load-rx (regexp
eb50: 20 22 5e 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c "^([\\d\\.]+)\\
eb60: 73 2b 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 s+([\\d\\.]+)\\s
eb70: 2b 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b +([\\d\\.]+)\\s+
eb80: 2e 2a 24 22 29 29 0a 3b 3b 3b 20 09 20 20 28 70 .*$")).;;; . (p
eb90: 72 6f 63 2d 72 78 20 20 28 72 65 67 65 78 70 20 roc-rx (regexp
eba0: 22 5e 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a "^processor\\s+:
ebb0: 5c 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 \\s+(\\d+)\\s*$"
ebc0: 29 29 0a 3b 3b 3b 20 09 20 20 28 63 6f 72 65 2d )).;;; . (core-
ebd0: 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 63 6f rx (regexp "^co
ebe0: 72 65 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c re id\\s+:\\s+(\
ebf0: 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 3b 3b 3b \d+)\\s*$")).;;;
ec00: 20 09 20 20 28 70 68 79 73 2d 72 78 20 20 28 72 . (phys-rx (r
ec10: 65 67 65 78 70 20 22 5e 70 68 79 73 69 63 61 6c egexp "^physical
ec20: 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 id\\s+:\\s+(\\d
ec30: 2b 29 5c 5c 73 2a 24 22 29 29 0a 3b 3b 3b 20 09 +)\\s*$")).;;; .
ec40: 20 20 28 6d 61 78 2d 6e 75 6d 20 20 28 6c 61 6d (max-num (lam
ec50: 62 64 61 20 28 70 20 6e 29 28 6d 61 78 20 28 73 bda (p n)(max (s
ec60: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 29 tring->number p)
ec70: 20 6e 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 n)))).;;;
ec80: 20 3b 3b 20 28 70 72 69 6e 74 20 22 64 61 74 61 ;; (print "data
ec90: 3d 22 20 64 61 74 61 29 0a 3b 3b 3b 20 20 20 20 =" data).;;;
eca0: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 (if (null? da
ecb0: 74 61 29 20 3b 3b 20 73 6f 6d 65 74 68 69 6e 67 ta) ;; something
ecc0: 20 77 65 6e 74 20 77 72 6f 6e 67 0a 3b 3b 3b 20 went wrong.;;;
ecd0: 09 20 20 23 66 0a 3b 3b 3b 20 09 20 20 28 6c 65 . #f.;;; . (le
ece0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 t loop ((hed
ecf0: 20 20 28 63 61 72 20 64 61 74 61 29 29 0a 3b 3b (car data)).;;
ed00: 3b 20 09 09 20 20 20 20 20 28 74 61 6c 20 20 20 ; .. (tal
ed10: 20 20 20 28 63 64 72 20 64 61 74 61 29 29 0a 3b (cdr data)).;
ed20: 3b 3b 20 09 09 20 20 20 20 20 28 6c 6f 61 64 73 ;; .. (loads
ed30: 20 20 20 20 23 66 29 0a 3b 3b 3b 20 09 09 20 20 #f).;;; ..
ed40: 20 20 20 28 70 72 6f 63 2d 6e 75 6d 20 30 29 20 (proc-num 0)
ed50: 20 3b 3b 20 70 72 6f 63 65 73 73 6f 72 20 69 6e ;; processor in
ed60: 63 6c 75 64 65 73 20 74 68 72 65 61 64 73 0a 3b cludes threads.;
ed70: 3b 3b 20 09 09 20 20 20 20 20 28 70 68 79 73 2d ;; .. (phys-
ed80: 6e 75 6d 20 30 29 20 20 3b 3b 20 70 68 79 73 69 num 0) ;; physi
ed90: 63 61 6c 20 63 68 69 70 20 6f 6e 20 6d 6f 74 68 cal chip on moth
eda0: 65 72 62 6f 61 72 64 0a 3b 3b 3b 20 09 09 20 20 erboard.;;; ..
edb0: 20 20 20 28 63 6f 72 65 2d 6e 75 6d 20 30 29 29 (core-num 0))
edc0: 20 3b 3b 20 63 6f 72 65 0a 3b 3b 3b 20 09 20 20 ;; core.;;; .
edd0: 20 20 3b 3b 20 28 70 72 69 6e 74 20 68 65 64 20 ;; (print hed
ede0: 22 2c 20 22 20 6c 6f 61 64 73 20 22 2c 20 22 20 ", " loads ", "
edf0: 70 72 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 70 68 proc-num ", " ph
ee00: 79 73 2d 6e 75 6d 20 22 2c 20 22 20 63 6f 72 65 ys-num ", " core
ee10: 2d 6e 75 6d 29 0a 3b 3b 3b 20 09 20 20 20 20 28 -num).;;; . (
ee20: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b if (null? tal) ;
ee30: 3b 20 68 61 76 65 20 61 6c 6c 20 6f 75 72 20 64 ; have all our d
ee40: 61 74 61 2c 20 63 61 6c 63 75 6c 61 74 65 20 6e ata, calculate n
ee50: 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 20 61 ormalized load a
ee60: 6e 64 20 72 65 74 75 72 6e 20 72 65 73 75 6c 74 nd return result
ee70: 0a 3b 3b 3b 20 09 09 28 6c 65 74 2a 20 28 28 61 .;;; ..(let* ((a
ee80: 63 74 2d 70 72 6f 63 20 28 2b 20 70 72 6f 63 2d ct-proc (+ proc-
ee90: 6e 75 6d 20 31 29 29 0a 3b 3b 3b 20 09 09 20 20 num 1)).;;; ..
eea0: 20 20 20 20 20 28 61 63 74 2d 70 68 79 73 20 28 (act-phys (
eeb0: 2b 20 70 68 79 73 2d 6e 75 6d 20 31 29 29 0a 3b + phys-num 1)).;
eec0: 3b 3b 20 09 09 20 20 20 20 20 20 20 28 61 63 74 ;; .. (act
eed0: 2d 63 6f 72 65 20 28 2b 20 63 6f 72 65 2d 6e 75 -core (+ core-nu
eee0: 6d 20 31 29 29 0a 3b 3b 3b 20 09 09 20 20 20 20 m 1)).;;; ..
eef0: 20 20 20 28 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 (adj-proc-loa
ef00: 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 d (/ (car loads)
ef10: 20 61 63 74 2d 70 72 6f 63 29 29 0a 3b 3b 3b 20 act-proc)).;;;
ef20: 09 09 20 20 20 20 20 20 20 28 61 64 6a 2d 63 6f .. (adj-co
ef30: 72 65 2d 6c 6f 61 64 20 28 2f 20 28 63 61 72 20 re-load (/ (car
ef40: 6c 6f 61 64 73 29 20 61 63 74 2d 63 6f 72 65 29 loads) act-core)
ef50: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 20 20 28 ).;;; .. (
ef60: 72 65 73 75 6c 74 0a 3b 3b 3b 20 09 09 09 28 61 result.;;; ...(a
ef70: 70 70 65 6e 64 20 28 6c 69 73 74 20 28 63 6f 6e ppend (list (con
ef80: 73 20 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 s 'adj-proc-load
ef90: 20 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 29 0a adj-proc-load).
efa0: 3b 3b 3b 20 09 09 09 09 20 20 20 20 20 20 28 63 ;;; .... (c
efb0: 6f 6e 73 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f ons 'adj-core-lo
efc0: 61 64 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 ad adj-core-load
efd0: 29 29 0a 3b 3b 3b 20 09 09 09 09 28 6c 69 73 74 )).;;; ....(list
efe0: 20 28 63 6f 6e 73 20 27 31 6d 2d 6c 6f 61 64 20 (cons '1m-load
eff0: 28 63 61 72 20 6c 6f 61 64 73 29 29 0a 3b 3b 3b (car loads)).;;;
f000: 20 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e 73 .... (cons
f010: 20 27 35 6d 2d 6c 6f 61 64 20 28 63 61 64 72 20 '5m-load (cadr
f020: 6c 6f 61 64 73 29 29 0a 3b 3b 3b 20 09 09 09 09 loads)).;;; ....
f030: 20 20 20 20 20 20 28 63 6f 6e 73 20 27 31 35 6d (cons '15m
f040: 2d 6c 6f 61 64 20 28 63 61 64 64 72 20 6c 6f 61 -load (caddr loa
f050: 64 73 29 29 29 0a 3b 3b 3b 20 09 09 09 09 28 6c ds))).;;; ....(l
f060: 69 73 74 20 28 63 6f 6e 73 20 27 70 72 6f 63 20 ist (cons 'proc
f070: 61 63 74 2d 70 72 6f 63 29 0a 3b 3b 3b 20 09 09 act-proc).;;; ..
f080: 09 09 20 20 20 20 20 20 28 63 6f 6e 73 20 27 63 .. (cons 'c
f090: 6f 72 65 20 61 63 74 2d 63 6f 72 65 29 0a 3b 3b ore act-core).;;
f0a0: 3b 20 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e ; .... (con
f0b0: 73 20 27 70 68 79 73 20 61 63 74 2d 70 68 79 73 s 'phys act-phys
f0c0: 29 29 29 29 29 0a 3b 3b 3b 20 09 09 20 20 72 65 ))))).;;; .. re
f0d0: 73 75 6c 74 29 0a 3b 3b 3b 20 09 09 28 72 65 67 sult).;;; ..(reg
f0e0: 65 78 2d 63 61 73 65 0a 3b 3b 3b 20 09 09 20 20 ex-case.;;; ..
f0f0: 20 20 68 65 64 0a 3b 3b 3b 20 09 09 20 20 28 6c hed.;;; .. (l
f100: 6f 61 64 2d 72 78 20 20 28 20 78 20 6c 31 20 6c oad-rx ( x l1 l
f110: 35 20 6c 31 35 20 29 20 28 6c 6f 6f 70 20 28 63 5 l15 ) (loop (c
f120: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
f130: 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d (map string->num
f140: 62 65 72 20 28 6c 69 73 74 20 6c 31 20 6c 35 20 ber (list l1 l5
f150: 6c 31 35 29 29 20 70 72 6f 63 2d 6e 75 6d 20 70 l15)) proc-num p
f160: 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d hys-num core-num
f170: 29 29 0a 3b 3b 3b 20 09 09 20 20 28 70 72 6f 63 )).;;; .. (proc
f180: 2d 72 78 20 20 28 20 78 20 70 20 20 20 20 20 20 -rx ( x p
f190: 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 ) (loop (car
f1a0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f tal)(cdr tal) lo
f1b0: 61 64 73 20 20 20 20 20 20 20 20 20 20 20 28 6d ads (m
f1c0: 61 78 2d 6e 75 6d 20 70 20 70 72 6f 63 2d 6e 75 ax-num p proc-nu
f1d0: 6d 29 20 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 m) phys-num core
f1e0: 2d 6e 75 6d 29 29 0a 3b 3b 3b 20 09 09 20 20 28 -num)).;;; .. (
f1f0: 70 68 79 73 2d 72 78 20 20 28 20 78 20 70 20 20 phys-rx ( x p
f200: 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 ) (loop (
f210: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
f220: 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 20 ) loads
f230: 20 20 70 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 2d proc-num (max-
f240: 6e 75 6d 20 70 20 70 68 79 73 2d 6e 75 6d 29 20 num p phys-num)
f250: 63 6f 72 65 2d 6e 75 6d 29 29 0a 3b 3b 3b 20 09 core-num)).;;; .
f260: 09 20 20 28 63 6f 72 65 2d 72 78 20 20 28 20 78 . (core-rx ( x
f270: 20 63 20 20 20 20 20 20 20 20 20 29 20 28 6c 6f c ) (lo
f280: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
f290: 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 tal) loads
f2a0: 20 20 20 20 20 20 70 72 6f 63 2d 6e 75 6d 20 70 proc-num p
f2b0: 68 79 73 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 6d hys-num (max-num
f2c0: 20 63 20 63 6f 72 65 2d 6e 75 6d 29 29 29 0a 3b c core-num))).;
f2d0: 3b 3b 20 09 09 20 20 28 65 6c 73 65 20 0a 3b 3b ;; .. (else .;;
f2e0: 3b 20 09 09 20 20 20 28 62 65 67 69 6e 0a 3b 3b ; .. (begin.;;
f2f0: 3b 20 09 09 20 20 20 20 20 3b 3b 20 28 70 72 69 ; .. ;; (pri
f300: 6e 74 20 22 4e 4f 20 4d 41 54 43 48 3a 20 22 20 nt "NO MATCH: "
f310: 68 65 64 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 hed).;;; ..
f320: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
f330: 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 70 cdr tal) loads p
f340: 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d roc-num phys-num
f350: 20 63 6f 72 65 2d 6e 75 6d 29 29 29 29 29 29 29 core-num)))))))
f360: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 ))).;;; .;;; (de
f370: 66 69 6e 65 20 28 67 65 74 2d 68 6f 73 74 2d 73 fine (get-host-s
f380: 74 61 74 73 20 61 63 66 67 29 0a 3b 3b 3b 20 20 tats acfg).;;;
f390: 20 28 6c 65 74 20 28 28 73 74 61 74 73 2d 68 61 (let ((stats-ha
f3a0: 73 68 20 28 61 72 65 61 2d 73 74 61 74 73 20 61 sh (area-stats a
f3b0: 63 66 67 29 29 29 0a 3b 3b 3b 20 20 20 20 20 3b cfg))).;;; ;
f3c0: 3b 20 75 73 65 20 74 68 69 73 20 6f 70 70 6f 72 ; use this oppor
f3d0: 74 75 6e 69 74 79 20 74 6f 20 72 65 6d 6f 76 65 tunity to remove
f3e0: 20 72 65 66 65 72 65 6e 63 65 73 20 74 6f 20 64 references to d
f3f0: 62 66 69 6c 65 73 20 77 68 69 63 68 20 68 61 76 bfiles which hav
f400: 65 20 6e 6f 74 20 62 65 65 6e 20 61 63 63 65 73 e not been acces
f410: 73 65 64 20 69 6e 20 61 20 77 68 69 6c 65 0a 3b sed in a while.;
f420: 3b 3b 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ;; (for-each
f430: 0a 3b 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 64 .;;; (lambd
f440: 61 20 28 64 62 6e 61 6d 65 29 0a 3b 3b 3b 20 20 a (dbname).;;;
f450: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 74 (let* ((st
f460: 61 74 73 20 20 20 20 20 20 20 28 68 61 73 68 2d ats (hash-
f470: 74 61 62 6c 65 2d 72 65 66 20 73 74 61 74 73 2d table-ref stats-
f480: 68 61 73 68 20 64 62 6e 61 6d 65 29 29 0a 3b 3b hash dbname)).;;
f490: 3b 20 09 20 20 20 20 20 20 28 6c 61 73 74 2d 61 ; . (last-a
f4a0: 63 63 65 73 73 20 28 73 74 61 74 2d 77 68 65 6e ccess (stat-when
f4b0: 20 73 74 61 74 73 29 29 29 0a 3b 3b 3b 20 09 20 stats))).;;; .
f4c0: 28 69 66 20 28 61 6e 64 20 28 3e 20 6c 61 73 74 (if (and (> last
f4d0: 2d 61 63 63 65 73 73 20 30 29 20 20 20 20 20 20 -access 0)
f4e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f4f0: 20 20 20 20 20 20 20 3b 3b 20 69 66 20 7a 65 72 ;; if zer
f500: 6f 20 74 68 65 6e 20 74 68 65 72 65 20 68 61 73 o then there has
f510: 20 62 65 65 6e 20 6e 6f 20 61 63 63 65 73 73 0a been no access.
f520: 3b 3b 3b 20 09 09 20 20 28 3e 20 28 2d 20 28 63 ;;; .. (> (- (c
f530: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
f540: 6c 61 73 74 2d 61 63 63 65 73 73 29 20 31 30 29 last-access) 10)
f550: 29 20 20 20 20 20 3b 3b 20 6e 6f 74 20 75 73 65 ) ;; not use
f560: 64 20 69 6e 20 74 65 6e 20 73 65 63 6f 6e 64 73 d in ten seconds
f570: 0a 3b 3b 3b 20 09 20 20 20 20 20 28 62 65 67 69 .;;; . (begi
f580: 6e 0a 3b 3b 3b 20 09 20 20 20 20 20 20 20 28 70 n.;;; . (p
f590: 72 69 6e 74 20 22 52 65 6d 6f 76 69 6e 67 20 22 rint "Removing "
f5a0: 20 64 62 6e 61 6d 65 20 22 20 66 72 6f 6d 20 73 dbname " from s
f5b0: 74 61 74 73 20 6c 69 73 74 22 29 0a 3b 3b 3b 20 tats list").;;;
f5c0: 09 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 . (hash-ta
f5d0: 62 6c 65 2d 64 65 6c 65 74 65 21 20 73 74 61 74 ble-delete! stat
f5e0: 73 2d 68 61 73 68 20 64 62 6e 61 6d 65 29 20 3b s-hash dbname) ;
f5f0: 3b 20 72 65 6d 6f 76 65 20 66 72 6f 6d 20 73 74 ; remove from st
f600: 61 74 73 20 68 61 73 68 0a 3b 3b 3b 20 09 20 20 ats hash.;;; .
f610: 20 20 20 20 20 28 73 74 61 74 2d 64 62 73 2d 73 (stat-dbs-s
f620: 65 74 21 20 73 74 61 74 73 20 28 68 61 73 68 2d et! stats (hash-
f630: 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 73 table-keys stats
f640: 29 29 29 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 )))))).;;;
f650: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
f660: 20 73 74 61 74 73 2d 68 61 73 68 29 29 0a 3b 3b stats-hash)).;;
f670: 3b 20 20 20 20 20 0a 3b 3b 3b 20 20 20 20 20 60 ; .;;; `
f680: 28 2c 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 (,(hash-table->a
f690: 6c 69 73 74 20 28 61 72 65 61 2d 64 62 73 20 61 list (area-dbs a
f6a0: 63 66 67 29 29 20 3b 3b 20 64 62 6e 61 6d 65 20 cfg)) ;; dbname
f6b0: 3d 3e 20 72 61 6e 64 6e 75 6d 0a 3b 3b 3b 20 20 => randnum.;;;
f6c0: 20 20 20 20 20 2c 28 6d 61 70 20 28 6c 61 6d 62 ,(map (lamb
f6d0: 64 61 20 28 64 62 6e 61 6d 65 29 20 20 3b 3b 20 da (dbname) ;;
f6e0: 64 62 6e 61 6d 65 20 69 73 20 74 68 65 20 64 62 dbname is the db
f6f0: 20 6e 61 6d 65 0a 3b 3b 3b 20 09 20 20 20 20 20 name.;;; .
f700: 20 28 63 6f 6e 73 20 64 62 6e 61 6d 65 20 28 73 (cons dbname (s
f710: 74 61 74 2d 77 68 65 6e 20 28 68 61 73 68 2d 74 tat-when (hash-t
f720: 61 62 6c 65 2d 72 65 66 20 73 74 61 74 73 2d 68 able-ref stats-h
f730: 61 73 68 20 64 62 6e 61 6d 65 29 29 29 29 0a 3b ash dbname)))).;
f740: 3b 3b 20 09 20 20 20 20 28 68 61 73 68 2d 74 61 ;; . (hash-ta
f750: 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 73 2d 68 ble-keys stats-h
f760: 61 73 68 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 ash)).;;;
f770: 28 63 70 75 6c 6f 61 64 20 2e 20 2c 28 67 65 74 (cpuload . ,(get
f780: 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d -normalized-cpu-
f790: 6c 6f 61 64 29 29 29 29 29 0a 3b 3b 3b 20 20 20 load))))).;;;
f7a0: 20 20 23 3b 28 73 74 61 74 73 20 20 20 2e 20 2c #;(stats . ,
f7b0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 (map (lambda (k)
f7c0: 20 3b 3b 20 63 72 65 61 74 65 20 61 6e 20 61 6c ;; create an al
f7d0: 69 73 74 20 66 72 6f 6d 20 74 68 65 20 73 74 61 ist from the sta
f7e0: 74 73 20 64 61 74 61 0a 3b 3b 3b 20 09 09 20 20 ts data.;;; ..
f7f0: 20 20 20 20 20 28 63 6f 6e 73 20 6b 20 28 73 74 (cons k (st
f800: 61 74 2d 3e 61 6c 69 73 74 20 28 68 61 73 68 2d at->alist (hash-
f810: 74 61 62 6c 65 2d 72 65 66 20 28 61 72 65 61 2d table-ref (area-
f820: 73 74 61 74 73 20 61 63 66 67 29 20 6b 29 29 29 stats acfg) k)))
f830: 29 0a 3b 3b 3b 20 09 09 20 20 20 20 20 28 68 61 ).;;; .. (ha
f840: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 28 61 sh-table-keys (a
f850: 72 65 61 2d 73 74 61 74 73 20 61 63 66 67 29 29 rea-stats acfg))
f860: 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 23 3b 28 74 )).;;; .;;; #;(t
f870: 72 61 63 65 0a 3b 3b 3b 20 20 3b 3b 20 61 73 73 race.;;; ;; ass
f880: 76 0a 3b 3b 3b 20 20 3b 3b 20 63 64 72 0a 3b 3b v.;;; ;; cdr.;;
f890: 3b 20 20 3b 3b 20 63 61 61 72 0a 3b 3b 3b 20 20 ; ;; caar.;;;
f8a0: 3b 3b 20 3b 3b 20 63 64 72 0a 3b 3b 3b 20 20 3b ;; ;; cdr.;;; ;
f8b0: 3b 20 63 61 6c 6c 0a 3b 3b 3b 20 20 3b 3b 20 66 ; call.;;; ;; f
f8c0: 69 6e 61 6c 69 7a 65 2d 61 6c 6c 2d 64 62 2d 68 inalize-all-db-h
f8d0: 61 6e 64 6c 65 73 0a 3b 3b 3b 20 20 3b 3b 20 67 andles.;;; ;; g
f8e0: 65 74 2d 61 6c 6c 2d 73 65 72 76 65 72 2d 70 6b et-all-server-pk
f8f0: 74 73 0a 3b 3b 3b 20 20 3b 3b 20 67 65 74 2d 6e ts.;;; ;; get-n
f900: 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f ormalized-cpu-lo
f910: 61 64 0a 3b 3b 3b 20 20 3b 3b 20 67 65 74 2d 6e ad.;;; ;; get-n
f920: 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f ormalized-cpu-lo
f930: 61 64 2d 72 61 77 0a 3b 3b 3b 20 20 3b 3b 20 6c ad-raw.;;; ;; l
f940: 61 75 6e 63 68 0a 3b 3b 3b 20 20 3b 3b 20 6e 6d aunch.;;; ;; nm
f950: 73 67 2d 73 65 6e 64 0a 3b 3b 3b 20 20 3b 3b 20 sg-send.;;; ;;
f960: 70 72 6f 63 65 73 73 2d 64 62 2d 71 75 65 72 69 process-db-queri
f970: 65 73 0a 3b 3b 3b 20 20 3b 3b 20 72 65 63 65 69 es.;;; ;; recei
f980: 76 65 2d 6d 65 73 73 61 67 65 0a 3b 3b 3b 20 20 ve-message.;;;
f990: 3b 3b 20 73 74 64 2d 70 65 65 72 2d 68 61 6e 64 ;; std-peer-hand
f9a0: 6c 65 72 0a 3b 3b 3b 20 20 3b 3b 20 75 70 64 61 ler.;;; ;; upda
f9b0: 74 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 te-known-servers
f9c0: 0a 3b 3b 3b 20 20 3b 3b 20 77 6f 72 6b 2d 71 75 .;;; ;; work-qu
f9d0: 65 75 65 2d 70 72 6f 63 65 73 73 6f 72 0a 3b 3b eue-processor.;;
f9e0: 3b 20 20 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b ; ).;;; .;;; ;;
f9f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fa00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fa10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fa20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fa30: 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 3b 3b 20 6e 65 ======.;;; ;; ne
fa40: 74 75 74 69 6c 0a 3b 3b 3b 20 3b 3b 20 20 20 6d tutil.;;; ;; m
fa50: 6f 76 65 20 74 68 69 73 20 62 61 63 6b 20 74 6f ove this back to
fa60: 20 75 6c 65 78 2d 6e 65 74 75 74 69 6c 2e 73 63 ulex-netutil.sc
fa70: 6d 20 73 6f 6d 65 64 61 79 3f 0a 3b 3b 3b 20 3b m someday?.;;; ;
fa80: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
fa90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
faa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fac0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 3b 20 0a 3b 3b 3b =======.;;; .;;;
fad0: 20 3b 3b 20 23 69 6e 63 6c 75 64 65 20 3c 73 74 ;; #include <st
fae0: 64 69 6f 2e 68 3e 0a 3b 3b 3b 20 3b 3b 20 23 69 dio.h>.;;; ;; #i
faf0: 6e 63 6c 75 64 65 20 3c 6e 65 74 69 6e 65 74 2f nclude <netinet/
fb00: 69 6e 2e 68 3e 0a 3b 3b 3b 20 3b 3b 20 23 69 6e in.h>.;;; ;; #in
fb10: 63 6c 75 64 65 20 3c 73 74 72 69 6e 67 2e 68 3e clude <string.h>
fb20: 0a 3b 3b 3b 20 3b 3b 20 23 69 6e 63 6c 75 64 65 .;;; ;; #include
fb30: 20 3c 61 72 70 61 2f 69 6e 65 74 2e 68 3e 0a 3b <arpa/inet.h>.;
fb40: 3b 3b 20 0a 3b 3b 3b 20 28 66 6f 72 65 69 67 6e ;; .;;; (foreign
fb50: 2d 64 65 63 6c 61 72 65 20 22 23 69 6e 63 6c 75 -declare "#inclu
fb60: 64 65 20 5c 22 73 79 73 2f 74 79 70 65 73 2e 68 de \"sys/types.h
fb70: 5c 22 22 29 0a 3b 3b 3b 20 28 66 6f 72 65 69 67 \"").;;; (foreig
fb80: 6e 2d 64 65 63 6c 61 72 65 20 22 23 69 6e 63 6c n-declare "#incl
fb90: 75 64 65 20 5c 22 73 79 73 2f 73 6f 63 6b 65 74 ude \"sys/socket
fba0: 2e 68 5c 22 22 29 0a 3b 3b 3b 20 28 66 6f 72 65 .h\"").;;; (fore
fbb0: 69 67 6e 2d 64 65 63 6c 61 72 65 20 22 23 69 6e ign-declare "#in
fbc0: 63 6c 75 64 65 20 5c 22 69 66 61 64 64 72 73 2e clude \"ifaddrs.
fbd0: 68 5c 22 22 29 0a 3b 3b 3b 20 28 66 6f 72 65 69 h\"").;;; (forei
fbe0: 67 6e 2d 64 65 63 6c 61 72 65 20 22 23 69 6e 63 gn-declare "#inc
fbf0: 6c 75 64 65 20 5c 22 61 72 70 61 2f 69 6e 65 74 lude \"arpa/inet
fc00: 2e 68 5c 22 22 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 .h\"").;;; .;;;
fc10: 3b 3b 20 67 65 74 20 49 50 20 61 64 64 72 65 73 ;; get IP addres
fc20: 73 65 73 20 66 72 6f 6d 20 41 4c 4c 20 69 6e 74 ses from ALL int
fc30: 65 72 66 61 63 65 73 0a 3b 3b 3b 20 28 64 65 66 erfaces.;;; (def
fc40: 69 6e 65 20 67 65 74 2d 61 6c 6c 2d 69 70 73 0a ine get-all-ips.
fc50: 3b 3b 3b 20 20 20 28 66 6f 72 65 69 67 6e 2d 73 ;;; (foreign-s
fc60: 61 66 65 2d 6c 61 6d 62 64 61 2a 20 73 63 68 65 afe-lambda* sche
fc70: 6d 65 2d 6f 62 6a 65 63 74 20 28 29 0a 3b 3b 3b me-object ().;;;
fc80: 20 20 20 20 20 22 0a 3b 3b 3b 20 0a 3b 3b 3b 20 ".;;; .;;;
fc90: 2f 2f 20 66 72 6f 6d 20 68 74 74 70 73 3a 2f 2f // from https://
fca0: 73 74 61 63 6b 6f 76 65 72 66 6c 6f 77 2e 63 6f stackoverflow.co
fcb0: 6d 2f 71 75 65 73 74 69 6f 6e 73 2f 31 37 39 30 m/questions/1790
fcc0: 39 34 30 31 2f 6c 69 6e 75 78 2d 63 2d 67 65 74 9401/linux-c-get
fcd0: 2d 64 65 66 61 75 6c 74 2d 69 6e 74 65 72 66 61 -default-interfa
fce0: 63 65 73 2d 69 70 2d 61 64 64 72 65 73 73 20 3a ces-ip-address :
fcf0: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 .;;; .;;; .;;;
fd00: 20 20 20 43 5f 77 6f 72 64 20 6c 73 74 20 3d 20 C_word lst =
fd10: 43 5f 53 43 48 45 4d 45 5f 45 4e 44 5f 4f 46 5f C_SCHEME_END_OF_
fd20: 4c 49 53 54 2c 20 6c 65 6e 2c 20 73 74 72 2c 20 LIST, len, str,
fd30: 2a 61 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 73 74 *a;.;;; // st
fd40: 72 75 63 74 20 69 66 61 64 64 72 73 20 2a 69 66 ruct ifaddrs *if
fd50: 61 2c 20 2a 69 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 a, *i;.;;; //
fd60: 20 73 74 72 75 63 74 20 73 6f 63 6b 61 64 64 72 struct sockaddr
fd70: 20 2a 73 61 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 *sa;.;;; .;;;
fd80: 20 20 20 73 74 72 75 63 74 20 69 66 61 64 64 72 struct ifaddr
fd90: 73 20 2a 20 69 66 41 64 64 72 53 74 72 75 63 74 s * ifAddrStruct
fda0: 20 3d 20 4e 55 4c 4c 3b 0a 3b 3b 3b 20 20 20 20 = NULL;.;;;
fdb0: 20 73 74 72 75 63 74 20 69 66 61 64 64 72 73 20 struct ifaddrs
fdc0: 2a 20 69 66 61 20 3d 20 4e 55 4c 4c 3b 0a 3b 3b * ifa = NULL;.;;
fdd0: 3b 20 20 20 20 20 76 6f 69 64 20 2a 20 74 6d 70 ; void * tmp
fde0: 41 64 64 72 50 74 72 20 3d 20 4e 55 4c 4c 3b 0a AddrPtr = NULL;.
fdf0: 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 69 66 20 ;;; .;;; if
fe00: 28 20 67 65 74 69 66 61 64 64 72 73 28 26 69 66 ( getifaddrs(&if
fe10: 41 64 64 72 53 74 72 75 63 74 29 20 21 3d 20 30 AddrStruct) != 0
fe20: 29 0a 3b 3b 3b 20 20 20 20 20 20 20 43 5f 72 65 ).;;; C_re
fe30: 74 75 72 6e 28 43 5f 53 43 48 45 4d 45 5f 46 41 turn(C_SCHEME_FA
fe40: 4c 53 45 29 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 2f LSE);.;;; .;;; /
fe50: 2f 20 20 20 20 66 6f 72 20 28 69 20 3d 20 69 66 / for (i = if
fe60: 61 3b 20 69 20 21 3d 20 4e 55 4c 4c 3b 20 69 20 a; i != NULL; i
fe70: 3d 20 69 2d 3e 69 66 61 5f 6e 65 78 74 29 20 7b = i->ifa_next) {
fe80: 0a 3b 3b 3b 20 20 20 20 20 66 6f 72 20 28 69 66 .;;; for (if
fe90: 61 20 3d 20 69 66 41 64 64 72 53 74 72 75 63 74 a = ifAddrStruct
fea0: 3b 20 69 66 61 20 21 3d 20 4e 55 4c 4c 3b 20 69 ; ifa != NULL; i
feb0: 66 61 20 3d 20 69 66 61 2d 3e 69 66 61 5f 6e 65 fa = ifa->ifa_ne
fec0: 78 74 29 20 7b 0a 3b 3b 3b 20 20 20 20 20 20 20 xt) {.;;;
fed0: 20 20 69 66 20 28 69 66 61 2d 3e 69 66 61 5f 61 if (ifa->ifa_a
fee0: 64 64 72 2d 3e 73 61 5f 66 61 6d 69 6c 79 3d 3d ddr->sa_family==
fef0: 41 46 5f 49 4e 45 54 29 20 7b 20 2f 2f 20 43 68 AF_INET) { // Ch
ff00: 65 63 6b 20 69 74 20 69 73 0a 3b 3b 3b 20 20 20 eck it is.;;;
ff10: 20 20 20 20 20 20 20 20 20 20 2f 2f 20 61 20 76 // a v
ff20: 61 6c 69 64 20 49 50 76 34 20 61 64 64 72 65 73 alid IPv4 addres
ff30: 73 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 s.;;;
ff40: 20 20 74 6d 70 41 64 64 72 50 74 72 20 3d 20 26 tmpAddrPtr = &
ff50: 28 28 73 74 72 75 63 74 20 73 6f 63 6b 61 64 64 ((struct sockadd
ff60: 72 5f 69 6e 20 2a 29 69 66 61 2d 3e 69 66 61 5f r_in *)ifa->ifa_
ff70: 61 64 64 72 29 2d 3e 73 69 6e 5f 61 64 64 72 3b addr)->sin_addr;
ff80: 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 .;;;
ff90: 20 63 68 61 72 20 61 64 64 72 65 73 73 42 75 66 char addressBuf
ffa0: 66 65 72 5b 49 4e 45 54 5f 41 44 44 52 53 54 52 fer[INET_ADDRSTR
ffb0: 4c 45 4e 5d 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 LEN];.;;;
ffc0: 20 20 20 20 20 20 69 6e 65 74 5f 6e 74 6f 70 28 inet_ntop(
ffd0: 41 46 5f 49 4e 45 54 2c 20 74 6d 70 41 64 64 72 AF_INET, tmpAddr
ffe0: 50 74 72 2c 20 61 64 64 72 65 73 73 42 75 66 66 Ptr, addressBuff
fff0: 65 72 2c 20 49 4e 45 54 5f 41 44 44 52 53 54 52 er, INET_ADDRSTR
10000 4c 45 4e 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 LEN);.;;; //
10010 20 20 20 20 20 20 20 20 70 72 69 6e 74 66 28 5c printf(\
10020 22 25 73 20 49 50 20 41 64 64 72 65 73 73 20 25 "%s IP Address %
10030 73 5c 5c 6e 5c 22 2c 20 69 66 61 2d 3e 69 66 61 s\\n\", ifa->ifa
10040 5f 6e 61 6d 65 2c 20 61 64 64 72 65 73 73 42 75 _name, addressBu
10050 66 66 65 72 29 3b 0a 3b 3b 3b 20 20 20 20 20 20 ffer);.;;;
10060 20 20 20 20 20 20 20 6c 65 6e 20 3d 20 73 74 72 len = str
10070 6c 65 6e 28 61 64 64 72 65 73 73 42 75 66 66 65 len(addressBuffe
10080 72 29 3b 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 r);.;;;
10090 20 20 20 20 61 20 3d 20 43 5f 61 6c 6c 6f 63 28 a = C_alloc(
100a0 43 5f 53 49 5a 45 4f 46 5f 50 41 49 52 20 2b 20 C_SIZEOF_PAIR +
100b0 43 5f 53 49 5a 45 4f 46 5f 53 54 52 49 4e 47 28 C_SIZEOF_STRING(
100c0 6c 65 6e 29 29 3b 0a 3b 3b 3b 20 20 20 20 20 20 len));.;;;
100d0 20 20 20 20 20 20 20 73 74 72 20 3d 20 43 5f 73 str = C_s
100e0 74 72 69 6e 67 28 26 61 2c 20 6c 65 6e 2c 20 61 tring(&a, len, a
100f0 64 64 72 65 73 73 42 75 66 66 65 72 29 3b 0a 3b ddressBuffer);.;
10100 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 6c ;; l
10110 73 74 20 3d 20 43 5f 61 5f 70 61 69 72 28 26 61 st = C_a_pair(&a
10120 2c 20 73 74 72 2c 20 6c 73 74 29 3b 0a 3b 3b 3b , str, lst);.;;;
10130 20 20 20 20 20 20 20 20 20 7d 20 0a 3b 3b 3b 20 } .;;;
10140 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 20 65 .;;; // e
10150 6c 73 65 20 69 66 20 28 69 66 61 2d 3e 69 66 61 lse if (ifa->ifa
10160 5f 61 64 64 72 2d 3e 73 61 5f 66 61 6d 69 6c 79 _addr->sa_family
10170 3d 3d 41 46 5f 49 4e 45 54 36 29 20 7b 20 2f 2f ==AF_INET6) { //
10180 20 43 68 65 63 6b 20 69 74 20 69 73 0a 3b 3b 3b Check it is.;;;
10190 20 2f 2f 20 20 20 20 20 20 20 20 20 20 20 20 2f // /
101a0 2f 20 61 20 76 61 6c 69 64 20 49 50 76 36 20 61 / a valid IPv6 a
101b0 64 64 72 65 73 73 0a 3b 3b 3b 20 2f 2f 20 20 20 ddress.;;; //
101c0 20 20 20 20 20 20 20 20 20 74 6d 70 41 64 64 72 tmpAddr
101d0 50 74 72 20 3d 20 26 28 28 73 74 72 75 63 74 20 Ptr = &((struct
101e0 73 6f 63 6b 61 64 64 72 5f 69 6e 36 20 2a 29 69 sockaddr_in6 *)i
101f0 66 61 2d 3e 69 66 61 5f 61 64 64 72 29 2d 3e 73 fa->ifa_addr)->s
10200 69 6e 36 5f 61 64 64 72 3b 0a 3b 3b 3b 20 2f 2f in6_addr;.;;; //
10210 20 20 20 20 20 20 20 20 20 20 20 20 63 68 61 72 char
10220 20 61 64 64 72 65 73 73 42 75 66 66 65 72 5b 49 addressBuffer[I
10230 4e 45 54 36 5f 41 44 44 52 53 54 52 4c 45 4e 5d NET6_ADDRSTRLEN]
10240 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 20 ;.;;; //
10250 20 20 20 20 69 6e 65 74 5f 6e 74 6f 70 28 41 46 inet_ntop(AF
10260 5f 49 4e 45 54 36 2c 20 74 6d 70 41 64 64 72 50 _INET6, tmpAddrP
10270 74 72 2c 20 61 64 64 72 65 73 73 42 75 66 66 65 tr, addressBuffe
10280 72 2c 20 49 4e 45 54 36 5f 41 44 44 52 53 54 52 r, INET6_ADDRSTR
10290 4c 45 4e 29 3b 0a 3b 3b 3b 20 2f 2f 2f 2f 20 20 LEN);.;;; ////
102a0 20 20 20 20 20 20 20 20 20 20 70 72 69 6e 74 66 printf
102b0 28 5c 22 25 73 20 49 50 20 41 64 64 72 65 73 73 (\"%s IP Address
102c0 20 25 73 5c 5c 6e 5c 22 2c 20 69 66 61 2d 3e 69 %s\\n\", ifa->i
102d0 66 61 5f 6e 61 6d 65 2c 20 61 64 64 72 65 73 73 fa_name, address
102e0 42 75 66 66 65 72 29 3b 0a 3b 3b 3b 20 2f 2f 20 Buffer);.;;; //
102f0 20 20 20 20 20 20 20 20 20 20 20 6c 65 6e 20 3d len =
10300 20 73 74 72 6c 65 6e 28 61 64 64 72 65 73 73 42 strlen(addressB
10310 75 66 66 65 72 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 uffer);.;;; //
10320 20 20 20 20 20 20 20 20 20 20 61 20 3d 20 43 5f a = C_
10330 61 6c 6c 6f 63 28 43 5f 53 49 5a 45 4f 46 5f 50 alloc(C_SIZEOF_P
10340 41 49 52 20 2b 20 43 5f 53 49 5a 45 4f 46 5f 53 AIR + C_SIZEOF_S
10350 54 52 49 4e 47 28 6c 65 6e 29 29 3b 0a 3b 3b 3b TRING(len));.;;;
10360 20 2f 2f 20 20 20 20 20 20 20 20 20 20 20 20 73 // s
10370 74 72 20 3d 20 43 5f 73 74 72 69 6e 67 28 26 61 tr = C_string(&a
10380 2c 20 6c 65 6e 2c 20 61 64 64 72 65 73 73 42 75 , len, addressBu
10390 66 66 65 72 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 ffer);.;;; //
103a0 20 20 20 20 20 20 20 20 20 6c 73 74 20 3d 20 43 lst = C
103b0 5f 61 5f 70 61 69 72 28 26 61 2c 20 73 74 72 2c _a_pair(&a, str,
103c0 20 6c 73 74 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 lst);.;;; //
103d0 20 20 20 20 7d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 2f }.;;; .;;; /
103e0 2f 20 20 20 20 20 20 20 65 6c 73 65 20 7b 0a 3b / else {.;
103f0 3b 3b 20 2f 2f 20 20 20 20 20 20 20 20 20 70 72 ;; // pr
10400 69 6e 74 66 28 5c 22 20 6e 6f 74 20 61 6e 20 49 intf(\" not an I
10410 50 76 34 20 61 64 64 72 65 73 73 5c 5c 6e 5c 22 Pv4 address\\n\"
10420 29 3b 0a 3b 3b 3b 20 2f 2f 20 20 20 20 20 20 20 );.;;; //
10430 7d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 7d }.;;; .;;; }
10440 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 66 72 .;;; .;;; fr
10450 65 65 69 66 61 64 64 72 73 28 69 66 61 29 3b 0a eeifaddrs(ifa);.
10460 3b 3b 3b 20 20 20 20 20 43 5f 72 65 74 75 72 6e ;;; C_return
10470 28 6c 73 74 29 3b 0a 3b 3b 3b 20 0a 3b 3b 3b 20 (lst);.;;; .;;;
10480 22 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 3b 3b 20 ")).;;; .;;; ;;
10490 43 68 61 6e 67 65 20 74 68 69 73 20 74 6f 20 62 Change this to b
104a0 69 61 73 20 66 6f 72 20 61 64 64 72 65 73 73 65 ias for addresse
104b0 73 20 77 69 74 68 20 61 20 72 65 61 73 6f 6e 61 s with a reasona
104c0 62 6c 65 20 62 72 6f 61 64 63 61 73 74 20 76 61 ble broadcast va
104d0 6c 75 65 3f 0a 3b 3b 3b 20 3b 3b 0a 3b 3b 3b 20 lue?.;;; ;;.;;;
104e0 28 64 65 66 69 6e 65 20 28 69 70 2d 70 72 65 66 (define (ip-pref
104f0 2d 6c 65 73 73 3f 20 61 20 62 29 0a 3b 3b 3b 20 -less? a b).;;;
10500 20 20 28 6c 65 74 2a 20 28 28 72 61 74 65 20 28 (let* ((rate (
10510 6c 61 6d 62 64 61 20 28 69 70 73 74 72 29 0a 3b lambda (ipstr).;
10520 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
10530 20 20 20 20 28 72 65 67 65 78 2d 63 61 73 65 20 (regex-case
10540 69 70 73 74 72 0a 3b 3b 3b 20 20 20 20 20 20 20 ipstr.;;;
10550 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10560 20 20 20 20 20 20 20 28 20 22 5e 31 32 37 5c 5c ( "^127\\
10570 2e 22 20 5f 20 30 20 29 0a 3b 3b 3b 20 20 20 20 ." _ 0 ).;;;
10580 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10590 20 20 20 20 20 20 20 20 20 20 28 20 22 5e 28 31 ( "^(1
105a0 30 5c 5c 2e 30 7c 31 39 32 5c 5c 2e 31 36 38 5c 0\\.0|192\\.168\
105b0 5c 2e 29 5c 5c 2e 2e 2a 22 20 5f 20 31 20 29 0a \.)\\..*" _ 1 ).
105c0 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;;
105d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
105e0 20 28 20 65 6c 73 65 20 32 20 29 20 29 29 29 29 ( else 2 ) ))))
105f0 0a 3b 3b 3b 20 20 20 20 20 28 3c 20 28 72 61 74 .;;; (< (rat
10600 65 20 61 29 20 28 72 61 74 65 20 62 29 29 29 29 e a) (rate b))))
10610 0a 3b 3b 3b 20 20 20 0a 3b 3b 3b 20 0a 3b 3b 3b .;;; .;;; .;;;
10620 20 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6d 79 (define (get-my
10630 2d 62 65 73 74 2d 61 64 64 72 65 73 73 29 0a 3b -best-address).;
10640 3b 3b 20 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d ;; (let ((all-
10650 6d 79 2d 61 64 64 72 65 73 73 65 73 20 28 67 65 my-addresses (ge
10660 74 2d 61 6c 6c 2d 69 70 73 29 29 0a 3b 3b 3b 20 t-all-ips)).;;;
10670 20 20 20 20 20 20 20 20 3b 3b 28 61 6c 6c 2d 6d ;;(all-m
10680 79 2d 61 64 64 72 65 73 73 65 73 2d 6f 6c 64 20 y-addresses-old
10690 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 (vector->list (h
106a0 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 ostinfo-addresse
106b0 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 s (hostname->hos
106c0 74 69 6e 66 6f 20 28 67 65 74 2d 68 6f 73 74 2d tinfo (get-host-
106d0 6e 61 6d 65 29 29 29 29 29 0a 3b 3b 3b 20 20 20 name))))).;;;
106e0 20 20 20 20 20 20 29 0a 3b 3b 3b 20 20 20 20 20 ).;;;
106f0 28 63 6f 6e 64 0a 3b 3b 3b 20 20 20 20 20 20 28 (cond.;;; (
10700 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 6d 79 2d 61 64 (null? all-my-ad
10710 64 72 65 73 73 65 73 29 0a 3b 3b 3b 20 20 20 20 dresses).;;;
10720 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d (get-host-nam
10730 65 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 e))
10740 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10750 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
10760 6e 6f 20 69 6e 74 65 72 66 61 63 65 73 3f 0a 3b no interfaces?.;
10770 3b 3b 20 20 20 20 20 20 28 28 65 71 3f 20 28 6c ;; ((eq? (l
10780 65 6e 67 74 68 20 61 6c 6c 2d 6d 79 2d 61 64 64 ength all-my-add
10790 72 65 73 73 65 73 29 20 31 29 0a 3b 3b 3b 20 20 resses) 1).;;;
107a0 20 20 20 20 20 28 63 61 72 20 61 6c 6c 2d 6d 79 (car all-my
107b0 2d 61 64 64 72 65 73 73 65 73 29 29 20 20 20 20 -addresses))
107c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
107d0 20 20 3b 3b 20 6f 6e 6c 79 20 6f 6e 65 20 74 6f ;; only one to
107e0 20 63 68 6f 6f 73 65 20 66 72 6f 6d 2c 20 6a 75 choose from, ju
107f0 73 74 20 67 6f 20 77 69 74 68 20 69 74 0a 3b 3b st go with it.;;
10800 3b 20 20 20 20 20 20 0a 3b 3b 3b 20 20 20 20 20 ; .;;;
10810 20 28 65 6c 73 65 0a 3b 3b 3b 20 20 20 20 20 20 (else.;;;
10820 20 28 63 61 72 20 28 73 6f 72 74 20 61 6c 6c 2d (car (sort all-
10830 6d 79 2d 61 64 64 72 65 73 73 65 73 20 69 70 2d my-addresses ip-
10840 70 72 65 66 2d 6c 65 73 73 3f 29 29 29 0a 3b 3b pref-less?))).;;
10850 3b 20 20 20 20 20 20 3b 3b 20 28 65 6c 73 65 20 ; ;; (else
10860 0a 3b 3b 3b 20 20 20 20 20 20 3b 3b 20 20 28 69 .;;; ;; (i
10870 70 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 20 28 p->string (car (
10880 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
10890 78 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 x)
108a0 20 20 20 20 20 20 20 20 3b 3b 20 74 61 6b 65 20 ;; take
108b0 61 6e 79 20 62 75 74 20 31 32 37 2e 0a 3b 3b 3b any but 127..;;;
108c0 20 20 20 20 20 20 3b 3b 20 20 20 20 09 09 09 20 ;; ...
108d0 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 (not (eq? (u8vec
108e0 74 6f 72 2d 72 65 66 20 78 20 30 29 20 31 32 37 tor-ref x 0) 127
108f0 29 29 29 0a 3b 3b 3b 20 20 20 20 20 20 3b 3b 20 ))).;;; ;;
10900 20 20 20 09 09 20 20 20 20 20 20 20 61 6c 6c 2d .. all-
10910 6d 79 2d 61 64 64 72 65 73 73 65 73 29 29 29 29 my-addresses))))
10920 0a 3b 3b 3b 20 0a 3b 3b 3b 20 20 20 20 20 20 29 .;;; .;;; )
10930 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 64 65 66 )).;;; .;;; (def
10940 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 ine (get-all-ips
10950 2d 73 6f 72 74 65 64 29 0a 3b 3b 3b 20 20 20 28 -sorted).;;; (
10960 73 6f 72 74 20 28 67 65 74 2d 61 6c 6c 2d 69 70 sort (get-all-ip
10970 73 29 20 69 70 2d 70 72 65 66 2d 6c 65 73 73 3f s) ip-pref-less?
10980 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 0a 0a )).;;; .;;; ..