Artifact
4e7e7a69945da3eaacae55e83b5302293fc400dc:
0000: 3b 3b 20 75 6c 65 78 3a 20 44 69 73 74 72 69 62 ;; ulex: Distrib
0010: 75 74 65 64 20 73 71 6c 69 74 65 33 20 64 62 0a uted sqlite3 db.
0020: 3b 3b 3b 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 ;;;.;; Copyright
0030: 20 28 43 29 20 32 30 31 38 2d 32 30 32 31 20 4d (C) 2018-2021 M
0040: 61 74 74 20 57 65 6c 6c 61 6e 64 0a 3b 3b 20 52 att Welland.;; R
0050: 65 64 69 73 74 72 69 62 75 74 69 6f 6e 20 61 6e edistribution an
0060: 64 20 75 73 65 20 69 6e 20 73 6f 75 72 63 65 20 d use in source
0070: 61 6e 64 20 62 69 6e 61 72 79 20 66 6f 72 6d 73 and binary forms
0080: 2c 20 77 69 74 68 20 6f 72 20 77 69 74 68 6f 75 , with or withou
0090: 74 0a 3b 3b 20 6d 6f 64 69 66 69 63 61 74 69 6f t.;; modificatio
00a0: 6e 2c 20 69 73 20 70 65 72 6d 69 74 74 65 64 2e n, is permitted.
00b0: 0a 3b 3b 0a 3b 3b 20 54 48 49 53 20 53 4f 46 54 .;;.;; THIS SOFT
00c0: 57 41 52 45 20 49 53 20 50 52 4f 56 49 44 45 44 WARE IS PROVIDED
00d0: 20 42 59 20 54 48 45 20 41 55 54 48 4f 52 20 60 BY THE AUTHOR `
00e0: 60 41 53 20 49 53 27 27 20 41 4e 44 20 41 4e 59 `AS IS'' AND ANY
00f0: 20 45 58 50 52 45 53 53 0a 3b 3b 20 4f 52 20 49 EXPRESS.;; OR I
0100: 4d 50 4c 49 45 44 20 57 41 52 52 41 4e 54 49 45 MPLIED WARRANTIE
0110: 53 2c 20 49 4e 43 4c 55 44 49 4e 47 2c 20 42 55 S, INCLUDING, BU
0120: 54 20 4e 4f 54 20 4c 49 4d 49 54 45 44 20 54 4f T NOT LIMITED TO
0130: 2c 20 54 48 45 20 49 4d 50 4c 49 45 44 0a 3b 3b , THE IMPLIED.;;
0140: 20 57 41 52 52 41 4e 54 49 45 53 20 4f 46 20 4d WARRANTIES OF M
0150: 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 41 ERCHANTABILITY A
0160: 4e 44 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 ND FITNESS FOR A
0170: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0180: 4f 53 45 0a 3b 3b 20 41 52 45 20 44 49 53 43 4c OSE.;; ARE DISCL
0190: 41 49 4d 45 44 2e 20 20 49 4e 20 4e 4f 20 45 56 AIMED. IN NO EV
01a0: 45 4e 54 20 53 48 41 4c 4c 20 54 48 45 20 41 55 ENT SHALL THE AU
01b0: 54 48 4f 52 20 4f 52 20 43 4f 4e 54 52 49 42 55 THOR OR CONTRIBU
01c0: 54 4f 52 53 20 42 45 0a 3b 3b 20 4c 49 41 42 4c TORS BE.;; LIABL
01d0: 45 20 46 4f 52 20 41 4e 59 20 44 49 52 45 43 54 E FOR ANY DIRECT
01e0: 2c 20 49 4e 44 49 52 45 43 54 2c 20 49 4e 43 49 , INDIRECT, INCI
01f0: 44 45 4e 54 41 4c 2c 20 53 50 45 43 49 41 4c 2c DENTAL, SPECIAL,
0200: 20 45 58 45 4d 50 4c 41 52 59 2c 20 4f 52 0a 3b EXEMPLARY, OR.;
0210: 3b 20 43 4f 4e 53 45 51 55 45 4e 54 49 41 4c 20 ; CONSEQUENTIAL
0220: 44 41 4d 41 47 45 53 20 28 49 4e 43 4c 55 44 49 DAMAGES (INCLUDI
0230: 4e 47 2c 20 42 55 54 20 4e 4f 54 20 4c 49 4d 49 NG, BUT NOT LIMI
0240: 54 45 44 20 54 4f 2c 20 50 52 4f 43 55 52 45 4d TED TO, PROCUREM
0250: 45 4e 54 0a 3b 3b 20 4f 46 20 53 55 42 53 54 49 ENT.;; OF SUBSTI
0260: 54 55 54 45 20 47 4f 4f 44 53 20 4f 52 20 53 45 TUTE GOODS OR SE
0270: 52 56 49 43 45 53 3b 20 4c 4f 53 53 20 4f 46 20 RVICES; LOSS OF
0280: 55 53 45 2c 20 44 41 54 41 2c 20 4f 52 20 50 52 USE, DATA, OR PR
0290: 4f 46 49 54 53 3b 20 4f 52 0a 3b 3b 20 42 55 53 OFITS; OR.;; BUS
02a0: 49 4e 45 53 53 20 49 4e 54 45 52 52 55 50 54 49 INESS INTERRUPTI
02b0: 4f 4e 29 20 48 4f 57 45 56 45 52 20 43 41 55 53 ON) HOWEVER CAUS
02c0: 45 44 20 41 4e 44 20 4f 4e 20 41 4e 59 20 54 48 ED AND ON ANY TH
02d0: 45 4f 52 59 20 4f 46 0a 3b 3b 20 4c 49 41 42 49 EORY OF.;; LIABI
02e0: 4c 49 54 59 2c 20 57 48 45 54 48 45 52 20 49 4e LITY, WHETHER IN
02f0: 20 43 4f 4e 54 52 41 43 54 2c 20 53 54 52 49 43 CONTRACT, STRIC
0300: 54 20 4c 49 41 42 49 4c 49 54 59 2c 20 4f 52 20 T LIABILITY, OR
0310: 54 4f 52 54 0a 3b 3b 20 28 49 4e 43 4c 55 44 49 TORT.;; (INCLUDI
0320: 4e 47 20 4e 45 47 4c 49 47 45 4e 43 45 20 4f 52 NG NEGLIGENCE OR
0330: 20 4f 54 48 45 52 57 49 53 45 29 20 41 52 49 53 OTHERWISE) ARIS
0340: 49 4e 47 20 49 4e 20 41 4e 59 20 57 41 59 20 4f ING IN ANY WAY O
0350: 55 54 20 4f 46 20 54 48 45 0a 3b 3b 20 55 53 45 UT OF THE.;; USE
0360: 20 4f 46 20 54 48 49 53 20 53 4f 46 54 57 41 52 OF THIS SOFTWAR
0370: 45 2c 20 45 56 45 4e 20 49 46 20 41 44 56 49 53 E, EVEN IF ADVIS
0380: 45 44 20 4f 46 20 54 48 45 20 50 4f 53 53 49 42 ED OF THE POSSIB
0390: 49 4c 49 54 59 20 4f 46 20 53 55 43 48 0a 3b 3b ILITY OF SUCH.;;
03a0: 20 44 41 4d 41 47 45 2e 0a 0a 3b 3b 3d 3d 3d 3d DAMAGE...;;====
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 3d 3d ================
03f0: 3d 3d 0a 3b 3b 20 41 42 4f 55 54 3a 0a 3b 3b 20 ==.;; ABOUT:.;;
0400: 20 20 53 65 65 20 52 45 41 44 4d 45 20 69 6e 20 See README in
0410: 74 68 65 20 64 69 73 74 72 69 62 75 74 69 6f 6e the distribution
0420: 20 61 74 20 68 74 74 70 73 3a 2f 2f 77 77 77 2e at https://www.
0430: 6b 69 61 74 6f 61 2e 63 6f 6d 2f 66 6f 73 73 69 kiatoa.com/fossi
0440: 6c 73 2f 75 6c 65 78 0a 3b 3b 20 4e 4f 54 45 53 ls/ulex.;; NOTES
0450: 3a 0a 3b 3b 20 20 20 57 68 79 20 73 71 6c 2d 64 :.;; Why sql-d
0460: 65 2d 6c 69 74 65 20 61 6e 64 20 6e 6f 74 20 73 e-lite and not s
0470: 61 79 2c 20 64 62 69 3f 20 20 2d 20 70 65 72 66 ay, dbi? - perf
0480: 6f 72 6d 61 6e 63 65 20 6d 6f 73 74 6c 79 2c 20 ormance mostly,
0490: 74 68 65 6e 20 73 69 6d 70 6c 69 63 69 74 79 2e then simplicity.
04a0: 0a 3b 3b 0a 3b 3b 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 3d 3d 3d 3d 0a 0a 28 6d ============..(m
04f0: 6f 64 75 6c 65 20 75 6c 65 78 0a 09 2a 0a 09 23 odule ulex..*..#
0500: 3b 28 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b ;(. . ;;
0510: 20 4e 4f 54 45 3a 20 6c 6f 6f 6b 69 6e 67 20 66 NOTE: looking f
0520: 6f 72 20 74 68 65 20 68 61 6e 64 6c 65 72 20 70 or the handler p
0530: 72 6f 63 20 2d 20 66 69 6e 64 20 74 68 65 20 72 roc - find the r
0540: 75 6e 2d 6c 69 73 74 65 6e 65 72 20 3a 29 0a 20 un-listener :).
0550: 20 20 20 20 0a 20 20 20 20 20 72 75 6e 2d 6c 69 . run-li
0560: 73 74 65 6e 65 72 20 20 20 20 20 3b 3b 20 28 72 stener ;; (r
0570: 75 6e 2d 6c 69 73 74 65 6e 65 72 20 68 61 6e 64 un-listener hand
0580: 6c 65 72 2d 70 72 6f 63 20 5b 70 6f 72 74 5d 29 ler-proc [port])
0590: 20 3d 3e 20 75 63 6f 6e 6e 0a 0a 20 20 20 20 20 => uconn..
05a0: 3b 3b 20 4e 4f 54 45 3a 20 68 61 6e 64 6c 65 72 ;; NOTE: handler
05b0: 2d 70 72 6f 63 20 70 61 72 61 6d 73 3b 0a 20 20 -proc params;.
05c0: 20 20 20 3b 3b 20 20 20 20 20 20 20 28 68 61 6e ;; (han
05d0: 64 6c 65 72 2d 70 72 6f 63 20 72 65 6d 2d 68 6f dler-proc rem-ho
05e0: 73 74 2d 70 6f 72 74 20 71 72 79 6b 65 79 20 63 st-port qrykey c
05f0: 6d 64 20 70 61 72 61 6d 73 29 0a 0a 20 20 20 20 md params)..
0600: 20 73 65 6e 64 2d 72 65 63 65 69 76 65 20 20 20 send-receive
0610: 20 20 3b 3b 20 28 73 65 6e 64 2d 72 65 63 65 69 ;; (send-recei
0620: 76 65 20 75 63 6f 6e 6e 20 68 6f 73 74 2d 70 6f ve uconn host-po
0630: 72 74 20 63 6d 64 20 64 61 74 61 29 0a 0a 20 20 rt cmd data)..
0640: 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 63 6d 64 20 ;; NOTE: cmd
0650: 63 61 6e 20 62 65 20 61 6e 79 20 70 6c 61 69 6e can be any plain
0660: 20 74 65 78 74 20 73 79 6d 62 6f 6c 20 65 78 63 text symbol exc
0670: 65 70 74 20 66 6f 72 20 74 68 65 73 65 3b 0a 20 ept for these;.
0680: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 27 ;; '
0690: 70 69 6e 67 20 27 61 63 6b 20 27 67 6f 6f 64 62 ping 'ack 'goodb
06a0: 79 65 20 27 72 65 73 70 6f 6e 73 65 0a 20 20 20 ye 'response.
06b0: 20 20 0a 20 20 20 20 20 73 65 74 2d 77 6f 72 6b . set-work
06c0: 2d 68 61 6e 64 6c 65 72 20 3b 3b 20 28 73 65 74 -handler ;; (set
06d0: 2d 77 6f 72 6b 2d 68 61 6e 64 6c 65 72 20 70 72 -work-handler pr
06e0: 6f 63 29 0a 0a 20 20 20 20 20 77 61 69 74 2d 61 oc).. wait-a
06f0: 6e 64 2d 63 6c 6f 73 65 20 20 20 3b 3b 20 28 77 nd-close ;; (w
0700: 61 69 74 2d 61 6e 64 2d 63 6c 6f 73 65 20 75 63 ait-and-close uc
0710: 6f 6e 6e 29 0a 0a 20 20 20 20 20 75 6c 65 78 2d onn).. ulex-
0720: 6c 69 73 74 65 6e 65 72 3f 0a 20 20 20 20 20 0a listener?. .
0730: 20 20 20 20 20 3b 3b 20 6e 65 65 64 65 64 20 74 ;; needed t
0740: 6f 20 67 65 74 20 74 68 65 20 69 6e 74 65 72 66 o get the interf
0750: 61 63 65 3a 70 6f 72 74 20 74 68 61 74 20 77 61 ace:port that wa
0760: 73 20 61 75 74 6f 6d 61 74 69 63 61 6c 6c 79 20 s automatically
0770: 66 6f 75 6e 64 0a 20 20 20 20 20 75 64 61 74 2d found. udat-
0780: 70 6f 72 74 0a 20 20 20 20 20 75 64 61 74 2d 68 port. udat-h
0790: 6f 73 74 2d 70 6f 72 74 0a 20 20 20 20 20 0a 20 ost-port. .
07a0: 20 20 20 20 3b 3b 20 66 6f 72 20 74 65 73 74 69 ;; for testi
07b0: 6e 67 20 6f 6e 6c 79 0a 20 20 20 20 20 3b 3b 20 ng only. ;;
07c0: 70 70 2d 75 63 6f 6e 6e 0a 20 20 20 20 20 0a 20 pp-uconn. .
07d0: 20 20 20 20 3b 3b 20 70 61 72 61 6d 65 74 65 72 ;; parameter
07e0: 73 0a 20 20 20 20 20 77 6f 72 6b 2d 6d 65 74 68 s. work-meth
07f0: 6f 64 20 20 20 3b 3b 20 70 61 72 61 6d 65 74 65 od ;; paramete
0800: 72 3b 20 27 74 68 72 65 61 64 73 2c 20 27 6d 61 r; 'threads, 'ma
0810: 69 6c 62 6f 78 2c 20 27 6c 69 6d 69 74 65 64 2c ilbox, 'limited,
0820: 20 27 64 69 72 65 63 74 0a 20 20 20 20 20 72 65 'direct. re
0830: 74 75 72 6e 2d 6d 65 74 68 6f 64 20 3b 3b 20 70 turn-method ;; p
0840: 61 72 61 6d 65 74 65 72 3b 20 27 6d 61 69 6c 62 arameter; 'mailb
0850: 6f 78 2c 20 27 70 6f 6c 6c 69 6e 67 2c 20 27 64 ox, 'polling, 'd
0860: 69 72 65 63 74 0a 20 20 20 20 20 29 0a 0a 28 69 irect. )..(i
0870: 6d 70 6f 72 74 20 73 63 68 65 6d 65 0a 09 63 68 mport scheme..ch
0880: 69 63 6b 65 6e 2e 62 61 73 65 0a 09 63 68 69 63 icken.base..chic
0890: 6b 65 6e 2e 66 69 6c 65 0a 09 63 68 69 63 6b 65 ken.file..chicke
08a0: 6e 2e 69 6f 0a 09 63 68 69 63 6b 65 6e 2e 74 69 n.io..chicken.ti
08b0: 6d 65 0a 09 63 68 69 63 6b 65 6e 2e 63 6f 6e 64 me..chicken.cond
08c0: 69 74 69 6f 6e 0a 09 63 68 69 63 6b 65 6e 2e 70 ition..chicken.p
08d0: 6f 72 74 0a 09 63 68 69 63 6b 65 6e 2e 73 74 72 ort..chicken.str
08e0: 69 6e 67 0a 09 63 68 69 63 6b 65 6e 2e 73 6f 72 ing..chicken.sor
08f0: 74 0a 09 63 68 69 63 6b 65 6e 2e 70 72 65 74 74 t..chicken.prett
0900: 79 2d 70 72 69 6e 74 0a 09 63 68 69 63 6b 65 6e y-print..chicken
0910: 2e 74 63 70 0a 09 0a 09 61 64 64 72 65 73 73 2d .tcp....address-
0920: 69 6e 66 6f 0a 09 6d 61 69 6c 62 6f 78 0a 09 6d info..mailbox..m
0930: 61 74 63 68 61 62 6c 65 0a 09 3b 3b 20 71 75 65 atchable..;; que
0940: 75 65 73 0a 09 72 65 67 65 78 0a 09 72 65 67 65 ues..regex..rege
0950: 78 2d 63 61 73 65 0a 09 73 69 6d 70 6c 65 2d 65 x-case..simple-e
0960: 78 63 65 70 74 69 6f 6e 73 0a 09 73 31 31 6e 0a xceptions..s11n.
0970: 09 73 72 66 69 2d 31 0a 09 73 72 66 69 2d 31 38 .srfi-1..srfi-18
0980: 0a 09 73 72 66 69 2d 34 0a 09 73 72 66 69 2d 36 ..srfi-4..srfi-6
0990: 39 0a 09 73 79 73 74 65 6d 2d 69 6e 66 6f 72 6d 9..system-inform
09a0: 61 74 69 6f 6e 0a 09 3b 3b 20 74 63 70 36 0a 09 ation..;; tcp6..
09b0: 74 63 70 2d 73 65 72 76 65 72 0a 09 74 79 70 65 tcp-server..type
09c0: 64 2d 72 65 63 6f 72 64 73 0a 0a 09 6d 64 35 0a d-records...md5.
09d0: 09 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 0a .message-digest.
09e0: 09 28 70 72 65 66 69 78 20 62 61 73 65 36 34 20 .(prefix base64
09f0: 62 61 73 65 36 34 3a 29 0a 09 7a 33 0a 09 29 0a base64:)..z3..).
0a00: 0a 3b 3b 20 75 64 61 74 20 73 74 72 75 63 74 2c .;; udat struct,
0a10: 20 75 73 65 64 20 62 79 20 62 6f 74 68 20 63 61 used by both ca
0a20: 6c 6c 65 72 20 61 6e 64 20 63 61 6c 6c 65 65 0a ller and callee.
0a30: 3b 3b 20 69 6e 73 74 61 6e 74 69 61 74 65 64 20 ;; instantiated
0a40: 61 73 20 75 63 6f 6e 6e 20 62 79 20 63 6f 6e 76 as uconn by conv
0a50: 65 6e 74 69 6f 6e 0a 3b 3b 0a 28 64 65 66 73 74 ention.;;.(defst
0a60: 72 75 63 74 20 75 64 61 74 0a 20 20 3b 3b 20 74 ruct udat. ;; t
0a70: 68 65 20 6c 69 73 74 65 6e 65 72 20 73 69 64 65 he listener side
0a80: 0a 20 20 28 70 6f 72 74 20 23 66 29 0a 20 20 28 . (port #f). (
0a90: 68 6f 73 74 2d 70 6f 72 74 20 23 66 29 20 3b 3b host-port #f) ;;
0aa0: 20 6d 79 20 68 6f 73 74 3a 70 6f 72 74 0a 20 20 my host:port.
0ab0: 28 73 6f 63 6b 65 74 20 23 66 29 0a 20 20 3b 3b (socket #f). ;;
0ac0: 20 74 68 65 20 70 65 65 72 73 0a 20 20 28 70 65 the peers. (pe
0ad0: 65 72 73 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d ers (make-hash-
0ae0: 74 61 62 6c 65 29 29 20 3b 3b 20 68 6f 73 74 3a table)) ;; host:
0af0: 70 6f 72 74 2d 3e 70 65 65 72 0a 20 20 3b 3b 20 port->peer. ;;
0b00: 77 6f 72 6b 20 68 61 6e 64 6c 69 6e 67 0a 20 20 work handling.
0b10: 28 77 6f 72 6b 2d 71 75 65 75 65 20 28 6d 61 6b (work-queue (mak
0b20: 65 2d 6d 61 69 6c 62 6f 78 29 29 0a 20 20 28 77 e-mailbox)). (w
0b30: 6f 72 6b 2d 70 72 6f 63 20 20 23 66 29 20 20 20 ork-proc #f)
0b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
0b50: 73 65 74 20 62 79 20 75 73 65 72 0a 20 20 28 63 set by user. (c
0b60: 6e 75 6d 20 20 20 20 20 20 20 30 29 20 20 20 20 num 0)
0b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
0b80: 63 6f 6f 6b 69 65 20 6e 75 6d 62 65 72 0a 20 20 cookie number.
0b90: 28 6d 62 6f 78 65 73 20 20 20 20 20 28 6d 61 6b (mboxes (mak
0ba0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
0bb0: 3b 20 66 6f 72 20 74 68 65 20 72 65 70 6c 69 65 ; for the replie
0bc0: 73 0a 20 20 28 61 76 61 69 6c 2d 63 6d 62 6f 78 s. (avail-cmbox
0bd0: 65 73 20 27 28 29 29 20 20 20 20 20 20 20 20 20 es '())
0be0: 20 20 20 3b 3b 20 6c 69 73 74 20 6f 66 20 28 3c ;; list of (<
0bf0: 63 6f 6f 6b 69 65 3e 20 2e 20 3c 6d 62 6f 78 3e cookie> . <mbox>
0c00: 29 20 66 6f 72 20 72 65 2d 75 73 65 0a 20 20 3b ) for re-use. ;
0c10: 3b 20 74 68 72 65 61 64 73 0a 20 20 28 6e 75 6d ; threads. (num
0c20: 74 68 72 65 61 64 73 20 31 30 29 0a 20 20 28 63 threads 10). (c
0c30: 6d 64 2d 74 68 72 65 61 64 20 23 66 29 0a 20 20 md-thread #f).
0c40: 28 77 6f 72 6b 2d 71 75 65 75 65 2d 74 68 72 65 (work-queue-thre
0c50: 61 64 20 23 66 29 0a 20 20 28 6e 75 6d 2d 74 68 ad #f). (num-th
0c60: 72 65 61 64 73 2d 72 75 6e 6e 69 6e 67 20 30 29 reads-running 0)
0c70: 0a 20 20 29 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d . ) ..;;=======
0c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
0cc0: 3b 3b 20 73 65 72 69 61 6c 69 7a 61 74 69 6f 6e ;; serialization
0cd0: 0a 3b 3b 20 20 20 4e 4f 54 45 3a 20 49 27 76 65 .;; NOTE: I've
0ce0: 20 68 61 64 20 70 72 6f 62 6c 65 6d 73 20 77 69 had problems wi
0cf0: 74 68 20 72 65 61 64 2f 77 72 69 74 65 20 61 6e th read/write an
0d00: 64 20 73 31 31 6e 20 73 65 72 69 61 6c 69 7a 65 d s11n serialize
0d10: 2c 20 64 65 73 65 72 69 61 6c 69 7a 65 0a 3b 3b , deserialize.;;
0d20: 20 20 20 20 20 20 20 20 20 74 68 75 73 20 74 68 thus th
0d30: 65 20 69 6e 65 66 66 69 63 69 65 6e 74 20 6d 65 e inefficient me
0d40: 74 68 6f 64 20 68 65 72 65 0a 3b 3b 3d 3d 3d 3d thod here.;;====
0d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d90: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 73 65 72 69 ==..(define seri
0da0: 61 6c 69 7a 69 6e 67 2d 6d 65 74 68 6f 64 20 28 alizing-method (
0db0: 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 20 27 make-parameter '
0dc0: 63 6f 6d 70 6c 65 78 29 29 0a 0a 3b 3b 20 4e 4f complex))..;; NO
0dd0: 54 45 3a 20 43 61 6e 20 72 65 6d 6f 76 65 20 74 TE: Can remove t
0de0: 68 65 20 72 65 67 65 78 20 61 6e 64 20 62 61 73 he regex and bas
0df0: 65 36 34 20 65 6e 63 6f 64 69 6e 67 20 66 6f 72 e64 encoding for
0e00: 20 7a 6d 71 0a 28 64 65 66 69 6e 65 20 28 6f 62 zmq.(define (ob
0e10: 6a 2d 3e 73 74 72 69 6e 67 20 6f 62 6a 29 0a 20 j->string obj).
0e20: 20 28 63 61 73 65 20 28 73 65 72 69 61 6c 69 7a (case (serializ
0e30: 69 6e 67 2d 6d 65 74 68 6f 64 29 0a 20 20 20 20 ing-method).
0e40: 28 28 63 6f 6d 70 6c 65 78 29 0a 20 20 20 20 20 ((complex).
0e50: 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 (string-substitu
0e60: 74 65 0a 20 20 20 20 20 20 28 72 65 67 65 78 70 te. (regexp
0e70: 20 22 3d 22 29 20 22 5f 22 0a 20 20 20 20 20 20 "=") "_".
0e80: 28 62 61 73 65 36 34 3a 62 61 73 65 36 34 2d 65 (base64:base64-e
0e90: 6e 63 6f 64 65 20 0a 20 20 20 20 20 20 20 28 7a ncode . (z
0ea0: 33 3a 65 6e 63 6f 64 65 2d 62 75 66 66 65 72 0a 3:encode-buffer.
0eb0: 20 20 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 (with-ou
0ec0: 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 20 tput-to-string.
0ed0: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
0ee0: 20 28 29 28 73 65 72 69 61 6c 69 7a 65 20 6f 62 ()(serialize ob
0ef0: 6a 29 29 29 29 29 20 3b 3b 20 42 42 3a 20 73 65 j))))) ;; BB: se
0f00: 72 69 61 6c 69 7a 65 20 2d 20 74 68 69 73 20 69 rialize - this i
0f10: 73 0a 09 09 09 09 09 3b 3b 20 77 68 61 74 20 63 s......;; what c
0f20: 61 75 73 65 73 20 70 72 6f 62 6c 65 6d 73 0a 09 auses problems..
0f30: 09 09 09 09 3b 3b 20 62 65 74 77 65 65 6e 20 64 ....;; between d
0f40: 69 66 66 65 72 65 6e 74 20 62 75 69 6c 64 73 20 ifferent builds
0f50: 6f 66 0a 09 09 09 09 09 3b 3b 20 6d 65 67 61 74 of......;; megat
0f60: 65 73 74 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6e est communicatin
0f70: 67 2e 0a 09 09 09 09 09 3b 3b 20 73 65 72 69 61 g.......;; seria
0f80: 6c 69 7a 65 20 69 73 20 73 65 6e 73 69 74 69 76 lize is sensitiv
0f90: 65 20 74 6f 0a 09 09 09 09 09 3b 3b 20 62 69 6e e to......;; bin
0fa0: 61 72 79 20 69 6d 61 67 65 20 6f 66 20 6d 74 65 ary image of mte
0fb0: 73 74 2e 0a 20 20 20 20 20 20 23 74 29 29 0a 20 st.. #t)).
0fc0: 20 20 20 28 28 77 72 69 74 65 29 28 77 69 74 68 ((write)(with
0fd0: 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e -output-to-strin
0fe0: 67 20 28 6c 61 6d 62 64 61 20 28 29 28 77 72 69 g (lambda ()(wri
0ff0: 74 65 20 6f 62 6a 29 29 29 29 0a 20 20 20 20 28 te obj)))). (
1000: 28 73 31 31 6e 29 20 28 77 69 74 68 2d 6f 75 74 (s11n) (with-out
1010: 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 20 28 6c put-to-string (l
1020: 61 6d 62 64 61 20 28 29 28 73 65 72 69 61 6c 69 ambda ()(seriali
1030: 7a 65 20 6f 62 6a 29 29 29 29 0a 20 20 20 20 28 ze obj)))). (
1040: 65 6c 73 65 20 6f 62 6a 29 29 29 20 3b 3b 20 72 else obj))) ;; r
1050: 70 63 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 pc..(define (str
1060: 69 6e 67 2d 3e 6f 62 6a 20 6d 73 67 20 23 21 6b ing->obj msg #!k
1070: 65 79 20 28 74 72 61 6e 73 70 6f 72 74 20 27 68 ey (transport 'h
1080: 74 74 70 29 29 0a 20 20 28 63 61 73 65 20 28 73 ttp)). (case (s
1090: 65 72 69 61 6c 69 7a 69 6e 67 2d 6d 65 74 68 6f erializing-metho
10a0: 64 29 0a 20 20 20 20 28 28 63 6f 6d 70 6c 65 78 d). ((complex
10b0: 29 0a 20 20 20 20 20 28 69 66 20 28 73 74 72 69 ). (if (stri
10c0: 6e 67 3f 20 6d 73 67 29 0a 20 20 20 20 20 20 20 ng? msg).
10d0: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
10e0: 6f 6d 2d 73 74 72 69 6e 67 20 0a 20 20 20 20 20 om-string .
10f0: 20 20 20 20 20 20 20 20 28 7a 33 3a 64 65 63 6f (z3:deco
1100: 64 65 2d 62 75 66 66 65 72 0a 20 20 20 20 20 20 de-buffer.
1110: 20 20 20 20 20 20 20 20 28 62 61 73 65 36 34 3a (base64:
1120: 62 61 73 65 36 34 2d 64 65 63 6f 64 65 0a 20 20 base64-decode.
1130: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
1140: 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 ring-substitute
1150: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1160: 20 28 72 65 67 65 78 70 20 22 5f 22 29 20 22 3d (regexp "_") "=
1170: 22 20 6d 73 67 20 23 74 29 29 29 0a 20 20 20 20 " msg #t))).
1180: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
1190: 29 28 64 65 73 65 72 69 61 6c 69 7a 65 29 29 29 )(deserialize)))
11a0: 0a 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e . (begin
11b0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 . (pri
11c0: 6e 74 20 22 55 4c 45 58 20 45 52 52 4f 52 3a 20 nt "ULEX ERROR:
11d0: 63 61 6e 6e 6f 74 20 74 72 61 6e 73 6c 61 74 65 cannot translate
11e0: 20 72 65 63 65 69 76 65 64 20 64 61 74 61 20 5c received data \
11f0: 22 22 6d 73 67 22 5c 22 22 29 0a 20 20 20 20 20 ""msg"\"").
1200: 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c (print-cal
1210: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
1220: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 -error-port)).
1230: 20 20 20 20 20 20 20 20 20 6d 73 67 29 29 29 20 msg)))
1240: 3b 3b 20 63 72 75 64 65 20 72 65 70 6c 79 20 66 ;; crude reply f
1250: 6f 72 20 77 68 65 6e 20 74 68 69 6e 67 73 20 67 or when things g
1260: 6f 20 61 77 72 79 0a 20 20 20 20 28 28 77 72 69 o awry. ((wri
1270: 74 65 29 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 te)(with-input-f
1280: 72 6f 6d 2d 73 74 72 69 6e 67 20 6d 73 67 20 28 rom-string msg (
1290: 6c 61 6d 62 64 61 20 28 29 28 72 65 61 64 29 29 lambda ()(read))
12a0: 29 29 0a 20 20 20 20 28 28 73 31 31 6e 29 28 77 )). ((s11n)(w
12b0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 73 ith-input-from-s
12c0: 74 72 69 6e 67 20 6d 73 67 20 28 6c 61 6d 62 64 tring msg (lambd
12d0: 61 20 28 29 28 64 65 73 65 72 69 61 6c 69 7a 65 a ()(deserialize
12e0: 29 29 29 29 0a 20 20 20 20 28 65 6c 73 65 20 6d )))). (else m
12f0: 73 67 29 29 29 20 3b 3b 20 72 70 63 0a 0a 0a 3b sg))) ;; rpc...;
1300: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1340: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 6c 69 73 74 65 =======.;; liste
1350: 6e 65 72 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ner.;;==========
1360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
13a0: 20 69 73 20 75 63 6f 6e 6e 20 61 20 75 6c 65 78 is uconn a ulex
13b0: 20 63 6f 6e 6e 65 63 74 6f 72 20 28 6c 69 73 74 connector (list
13c0: 65 6e 65 72 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 ener).;;.(define
13d0: 20 28 75 6c 65 78 2d 6c 69 73 74 65 6e 65 72 3f (ulex-listener?
13e0: 20 75 63 6f 6e 6e 29 0a 20 20 28 75 64 61 74 3f uconn). (udat?
13f0: 20 75 63 6f 6e 6e 29 29 0a 0a 3b 3b 20 63 72 65 uconn))..;; cre
1400: 61 74 65 20 61 20 74 63 70 20 6c 69 73 74 65 6e ate a tcp listen
1410: 65 72 20 61 6e 64 20 72 65 74 75 72 6e 20 61 20 er and return a
1420: 70 6f 70 75 6c 61 74 65 64 20 75 64 61 74 20 73 populated udat s
1430: 74 72 75 63 74 20 77 69 74 68 0a 3b 3b 20 6d 79 truct with.;; my
1440: 20 70 6f 72 74 2c 20 61 64 64 72 65 73 73 2c 20 port, address,
1450: 68 6f 73 74 6e 61 6d 65 2c 20 70 69 64 20 65 74 hostname, pid et
1460: 63 2e 0a 3b 3b 20 72 65 74 75 72 6e 20 23 66 20 c..;; return #f
1470: 69 66 20 66 61 69 6c 20 74 6f 20 66 69 6e 64 20 if fail to find
1480: 61 20 70 6f 72 74 20 74 6f 20 61 6c 6c 6f 63 61 a port to alloca
1490: 74 65 2e 0a 3b 3b 0a 3b 3b 20 20 69 66 20 75 64 te..;;.;; if ud
14a0: 61 74 61 2d 69 6e 20 69 73 20 23 66 20 63 72 65 ata-in is #f cre
14b0: 61 74 65 20 74 68 65 20 72 65 63 6f 72 64 0a 3b ate the record.;
14c0: 3b 20 20 69 66 20 74 68 65 72 65 20 69 73 20 61 ; if there is a
14d0: 6c 72 65 61 64 79 20 61 20 73 65 72 76 2d 6c 69 lready a serv-li
14e0: 73 74 65 6e 65 72 20 72 65 74 75 72 6e 20 74 68 stener return th
14f0: 65 20 75 64 61 74 61 0a 3b 3b 0a 28 64 65 66 69 e udata.;;.(defi
1500: 6e 65 20 28 73 65 74 75 70 2d 6c 69 73 74 65 6e ne (setup-listen
1510: 65 72 20 75 63 6f 6e 6e 20 23 21 6f 70 74 69 6f er uconn #!optio
1520: 6e 61 6c 20 28 70 6f 72 74 20 34 32 34 32 29 29 nal (port 4242))
1530: 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
1540: 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 tions. exn.
1550: 28 69 66 20 28 3c 20 70 6f 72 74 20 36 35 35 33 (if (< port 6553
1560: 35 29 0a 20 20 20 20 20 20 20 28 73 65 74 75 70 5). (setup
1570: 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e 6e 20 -listener uconn
1580: 28 2b 20 70 6f 72 74 20 31 29 29 0a 20 20 20 20 (+ port 1)).
1590: 20 20 20 23 66 29 0a 20 20 20 28 63 6f 6e 6e 65 #f). (conne
15a0: 63 74 2d 6c 69 73 74 65 6e 65 72 20 75 63 6f 6e ct-listener ucon
15b0: 6e 20 70 6f 72 74 29 29 29 0a 0a 28 64 65 66 69 n port)))..(defi
15c0: 6e 65 20 28 63 6f 6e 6e 65 63 74 2d 6c 69 73 74 ne (connect-list
15d0: 65 6e 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 29 ener uconn port)
15e0: 0a 20 20 3b 3b 20 28 74 63 70 2d 6c 69 73 74 65 . ;; (tcp-liste
15f0: 6e 65 72 2d 73 6f 63 6b 65 74 20 4c 49 53 54 45 ner-socket LISTE
1600: 4e 45 52 29 28 73 6f 63 6b 65 74 2d 6e 61 6d 65 NER)(socket-name
1610: 20 73 6f 29 0a 20 20 3b 3b 20 73 6f 63 6b 61 64 so). ;; sockad
1620: 64 72 2d 61 64 64 72 65 73 73 2c 20 73 6f 63 6b dr-address, sock
1630: 61 64 64 72 2d 70 6f 72 74 2c 20 73 6f 63 6b 61 addr-port, socka
1640: 64 64 72 2d 3e 73 74 72 69 6e 67 0a 20 20 28 6c ddr->string. (l
1650: 65 74 2a 20 28 28 74 6c 73 6e 20 28 74 63 70 2d et* ((tlsn (tcp-
1660: 6c 69 73 74 65 6e 20 70 6f 72 74 20 31 30 30 30 listen port 1000
1670: 20 23 66 29 29 20 3b 3b 20 28 74 63 70 2d 6c 69 #f)) ;; (tcp-li
1680: 73 74 65 6e 20 54 43 50 50 4f 52 54 20 5b 42 41 sten TCPPORT [BA
1690: 43 4b 4c 4f 47 20 5b 48 4f 53 54 5d 5d 29 0a 09 CKLOG [HOST]])..
16a0: 20 28 61 64 64 72 20 28 67 65 74 2d 6d 79 2d 62 (addr (get-my-b
16b0: 65 73 74 2d 61 64 64 72 65 73 73 29 29 29 20 3b est-address))) ;
16c0: 3b 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 ; (hostinfo-addr
16d0: 65 73 73 65 73 20 28 68 6f 73 74 2d 69 6e 66 6f esses (host-info
16e0: 72 6d 61 74 69 6f 6e 20 28 63 75 72 72 65 6e 74 rmation (current
16f0: 2d 68 6f 73 74 6e 61 6d 65 29 29 29 0a 20 20 20 -hostname))).
1700: 20 28 75 64 61 74 2d 70 6f 72 74 2d 73 65 74 21 (udat-port-set!
1710: 20 20 20 20 20 20 75 63 6f 6e 6e 20 70 6f 72 74 uconn port
1720: 29 0a 20 20 20 20 28 75 64 61 74 2d 68 6f 73 74 ). (udat-host
1730: 2d 70 6f 72 74 2d 73 65 74 21 20 75 63 6f 6e 6e -port-set! uconn
1740: 20 28 63 6f 6e 63 20 61 64 64 72 22 3a 22 70 6f (conc addr":"po
1750: 72 74 29 29 0a 20 20 20 20 28 75 64 61 74 2d 73 rt)). (udat-s
1760: 6f 63 6b 65 74 2d 73 65 74 21 20 20 20 20 75 63 ocket-set! uc
1770: 6f 6e 6e 20 74 6c 73 6e 29 0a 20 20 20 20 75 63 onn tlsn). uc
1780: 6f 6e 6e 29 29 0a 0a 3b 3b 20 72 75 6e 2d 6c 69 onn))..;; run-li
1790: 73 74 65 6e 65 72 20 64 6f 65 73 20 61 6c 6c 20 stener does all
17a0: 74 68 65 20 77 6f 72 6b 20 6f 66 20 73 74 61 72 the work of star
17b0: 74 69 6e 67 20 61 20 6c 69 73 74 65 6e 65 72 20 ting a listener
17c0: 69 6e 20 61 20 74 68 72 65 61 64 0a 3b 3b 20 69 in a thread.;; i
17d0: 74 20 74 68 65 6e 20 72 65 74 75 72 6e 73 20 63 t then returns c
17e0: 6f 6e 74 72 6f 6c 0a 3b 3b 0a 28 64 65 66 69 6e ontrol.;;.(defin
17f0: 65 20 28 72 75 6e 2d 6c 69 73 74 65 6e 65 72 20 e (run-listener
1800: 68 61 6e 64 6c 65 72 2d 70 72 6f 63 20 23 21 6f handler-proc #!o
1810: 70 74 69 6f 6e 61 6c 20 28 70 6f 72 74 2d 73 75 ptional (port-su
1820: 67 67 65 73 74 69 6f 6e 20 34 32 34 32 29 29 0a ggestion 4242)).
1830: 20 20 28 6c 65 74 2a 20 28 28 75 63 6f 6e 6e 20 (let* ((uconn
1840: 28 6d 61 6b 65 2d 75 64 61 74 29 29 29 0a 20 20 (make-udat))).
1850: 20 20 28 75 64 61 74 2d 77 6f 72 6b 2d 70 72 6f (udat-work-pro
1860: 63 2d 73 65 74 21 20 75 63 6f 6e 6e 20 68 61 6e c-set! uconn han
1870: 64 6c 65 72 2d 70 72 6f 63 29 0a 20 20 20 20 28 dler-proc). (
1880: 69 66 20 28 73 65 74 75 70 2d 6c 69 73 74 65 6e if (setup-listen
1890: 65 72 20 75 63 6f 6e 6e 20 70 6f 72 74 2d 73 75 er uconn port-su
18a0: 67 67 65 73 74 69 6f 6e 29 0a 09 28 28 6d 61 6b ggestion)..((mak
18b0: 65 2d 74 63 70 2d 73 65 72 76 65 72 0a 09 20 20 e-tcp-server..
18c0: 28 75 64 61 74 2d 73 6f 63 6b 65 74 20 75 63 6f (udat-socket uco
18d0: 6e 6e 29 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 nn).. (lambda (
18e0: 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 72 ).. (let* ((r
18f0: 64 61 74 20 20 28 73 74 72 69 6e 67 2d 3e 6f 62 dat (string->ob
1900: 6a 20 28 72 65 61 64 29 29 20 23 3b 28 64 65 73 j (read)) #;(des
1910: 65 72 69 61 6c 69 7a 65 29 29 20 3b 3b 20 27 28 erialize)) ;; '(
1920: 6d 79 2d 68 6f 73 74 2d 70 6f 72 74 20 71 72 79 my-host-port qry
1930: 6b 65 79 20 63 6d 64 20 70 61 72 61 6d 73 29 0a key cmd params).
1940: 09 09 20 20 20 28 72 65 73 70 20 20 28 64 6f 2d .. (resp (do-
1950: 77 6f 72 6b 20 75 63 6f 6e 6e 20 72 64 61 74 29 work uconn rdat)
1960: 29 29 0a 09 20 20 20 20 20 20 28 77 72 69 74 65 )).. (write
1970: 20 28 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 72 65 (obj->string re
1980: 73 70 29 29 20 23 3b 28 73 65 72 69 61 6c 69 7a sp)) #;(serializ
1990: 65 20 72 65 73 70 29 29 29 29 29 0a 09 28 61 73 e resp)))))..(as
19a0: 73 65 72 74 20 23 66 20 22 45 52 52 4f 52 3a 20 sert #f "ERROR:
19b0: 72 75 6e 2d 6c 69 73 74 65 6e 65 72 20 63 61 6c run-listener cal
19c0: 6c 65 64 20 77 69 74 68 6f 75 74 20 70 72 6f 70 led without prop
19d0: 65 72 20 73 65 74 75 70 2e 22 29 29 29 29 0a 0a er setup."))))..
19e0: 28 64 65 66 69 6e 65 20 28 77 61 69 74 2d 61 6e (define (wait-an
19f0: 64 2d 63 6c 6f 73 65 20 75 63 6f 6e 6e 29 0a 20 d-close uconn).
1a00: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 28 (thread-join! (
1a10: 75 64 61 74 2d 63 6d 64 2d 74 68 72 65 61 64 20 udat-cmd-thread
1a20: 75 63 6f 6e 6e 29 29 0a 20 20 28 74 63 70 2d 63 uconn)). (tcp-c
1a30: 6c 6f 73 65 20 28 75 64 61 74 2d 73 6f 63 6b 65 lose (udat-socke
1a40: 74 20 75 63 6f 6e 6e 29 29 29 0a 0a 3b 3b 3d 3d t uconn)))..;;==
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a90: 3d 3d 3d 3d 0a 3b 3b 20 3d 3d 20 3c 3c 20 3b 3b ====.;; == << ;;
1aa0: 20 70 65 65 72 73 20 61 6e 64 20 63 6f 6e 6e 65 peers and conne
1ab0: 63 74 69 6f 6e 73 0a 3b 3b 20 3d 3d 20 3c 3c 20 ctions.;; == <<
1ac0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
1ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b00: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
1b10: 65 20 2a 73 65 6e 64 2d 6d 75 74 65 78 2a 20 28 e *send-mutex* (
1b20: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b make-mutex))..;;
1b30: 20 73 65 6e 64 20 73 74 72 75 63 74 75 72 65 64 send structured
1b40: 20 64 61 74 61 20 74 6f 20 72 65 63 69 70 69 65 data to recipie
1b50: 6e 74 0a 3b 3b 0a 3b 3b 20 20 4e 4f 54 45 3a 20 nt.;;.;; NOTE:
1b60: 71 72 79 6b 65 79 20 69 73 20 77 68 61 74 20 77 qrykey is what w
1b70: 61 73 20 63 61 6c 6c 65 64 20 74 68 65 20 22 63 as called the "c
1b80: 6f 6f 6b 69 65 22 20 70 72 65 76 69 6f 75 73 6c ookie" previousl
1b90: 79 0a 3b 3b 0a 3b 3b 20 20 20 20 20 72 65 74 76 y.;;.;; retv
1ba0: 61 6c 20 74 65 6c 6c 73 20 73 65 6e 64 20 74 6f al tells send to
1bb0: 20 65 78 70 65 63 74 20 61 6e 64 20 77 61 69 74 expect and wait
1bc0: 20 66 6f 72 20 72 65 74 75 72 6e 20 64 61 74 61 for return data
1bd0: 20 28 6f 6e 65 20 6c 69 6e 65 29 20 61 6e 64 20 (one line) and
1be0: 72 65 74 75 72 6e 20 69 74 20 6f 72 20 74 69 6d return it or tim
1bf0: 65 20 6f 75 74 0a 3b 3b 20 20 20 20 20 20 20 74 e out.;; t
1c00: 68 69 73 20 69 73 20 66 6f 72 20 70 69 6e 67 20 his is for ping
1c10: 77 68 65 72 65 20 77 65 20 64 6f 6e 27 74 20 77 where we don't w
1c20: 61 6e 74 20 74 6f 20 6e 65 63 65 73 73 61 72 69 ant to necessari
1c30: 6c 79 20 68 61 76 65 20 73 65 74 20 75 70 20 6f ly have set up o
1c40: 75 72 20 6f 77 6e 20 73 65 72 76 65 72 20 79 65 ur own server ye
1c50: 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 t..;;.(define (s
1c60: 65 6e 64 2d 72 65 63 65 69 76 65 20 75 64 61 74 end-receive udat
1c70: 61 20 68 6f 73 74 2d 70 6f 72 74 20 63 6d 64 20 a host-port cmd
1c80: 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
1c90: 28 28 68 6f 73 74 2d 70 6f 72 74 2d 6c 73 74 20 ((host-port-lst
1ca0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 68 6f (string-split ho
1cb0: 73 74 2d 70 6f 72 74 20 22 3a 22 29 29 0a 09 20 st-port ":"))..
1cc0: 28 68 6f 73 74 20 20 20 20 20 20 20 20 20 20 28 (host (
1cd0: 63 61 72 20 68 6f 73 74 2d 70 6f 72 74 2d 6c 73 car host-port-ls
1ce0: 74 29 29 0a 09 20 28 70 6f 72 74 20 20 20 20 20 t)).. (port
1cf0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
1d00: 6d 62 65 72 20 28 63 61 64 72 20 68 6f 73 74 2d mber (cadr host-
1d10: 70 6f 72 74 2d 6c 73 74 29 29 29 0a 09 20 28 6d port-lst))).. (m
1d20: 79 2d 68 6f 73 74 2d 70 6f 72 74 20 28 61 6e 64 y-host-port (and
1d30: 20 75 64 61 74 61 20 28 75 64 61 74 2d 68 6f 73 udata (udat-hos
1d40: 74 2d 70 6f 72 74 20 75 64 61 74 61 29 29 29 20 t-port udata)))
1d50: 20 20 20 20 20 20 20 20 20 3b 3b 20 72 65 6d 6f ;; remo
1d60: 74 65 20 77 69 6c 6c 20 72 65 74 75 72 6e 20 74 te will return t
1d70: 6f 20 74 68 69 73 0a 09 20 28 69 73 6d 65 20 20 o this.. (isme
1d80: 20 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 68 (equal? h
1d90: 6f 73 74 2d 70 6f 72 74 20 6d 79 2d 68 6f 73 74 ost-port my-host
1da0: 2d 70 6f 72 74 29 29 20 3b 3b 20 63 61 6c 6c 69 -port)) ;; calli
1db0: 6e 67 20 6d 79 73 65 6c 66 3f 0a 09 20 3b 3b 20 ng myself?.. ;;
1dc0: 64 61 74 20 69 73 20 61 20 73 65 6c 66 2d 63 6f dat is a self-co
1dd0: 6e 74 61 69 6e 65 64 20 77 6f 72 6b 20 62 6c 6f ntained work blo
1de0: 63 6b 20 74 68 61 74 20 63 61 6e 20 62 65 20 73 ck that can be s
1df0: 65 6e 74 20 6f 72 20 68 61 6e 64 6c 65 64 20 6c ent or handled l
1e00: 6f 63 61 6c 6c 79 0a 09 20 28 64 61 74 20 20 20 ocally.. (dat
1e10: 20 20 20 20 20 20 20 28 6c 69 73 74 20 6d 79 2d (list my-
1e20: 68 6f 73 74 2d 70 6f 72 74 20 27 71 72 79 6b 65 host-port 'qryke
1e30: 79 20 63 6d 64 20 70 61 72 61 6d 73 20 23 3b 28 y cmd params #;(
1e40: 63 6f 6e 73 20 28 63 75 72 72 65 6e 74 2d 73 65 cons (current-se
1e50: 63 6f 6e 64 73 29 28 63 75 72 72 65 6e 74 2d 6d conds)(current-m
1e60: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 29 29 illiseconds)))))
1e70: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
1e80: 28 69 73 6d 65 20 28 64 6f 2d 77 6f 72 6b 20 75 (isme (do-work u
1e90: 64 61 74 61 20 64 61 74 29 29 20 3b 3b 20 6e 6f data dat)) ;; no
1ea0: 20 74 72 61 6e 73 6d 69 73 73 69 6f 6e 20 6e 65 transmission ne
1eb0: 65 64 65 64 0a 20 20 20 20 20 28 65 6c 73 65 0a eded. (else.
1ec0: 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 (handle-ex
1ed0: 63 65 70 74 69 6f 6e 73 20 3b 3b 20 54 4f 44 4f ceptions ;; TODO
1ee0: 20 2d 20 4d 41 4b 45 20 54 48 49 53 20 45 58 43 - MAKE THIS EXC
1ef0: 45 50 54 49 4f 4e 20 43 4d 44 20 53 50 45 43 49 EPTION CMD SPECI
1f00: 46 49 43 3f 0a 20 20 20 20 20 20 20 65 78 6e 0a FIC?. exn.
1f10: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
1f20: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 55 (print "U
1f30: 4c 45 58 20 73 65 6e 64 2d 72 65 63 65 69 76 65 LEX send-receive
1f40: 3a 20 65 78 6e 3d 22 65 78 6e 29 0a 20 20 20 20 : exn="exn).
1f50: 20 20 20 20 20 28 6d 65 73 73 61 67 65 20 65 78 (message ex
1f60: 6e 29 29 0a 20 20 20 20 20 20 20 28 62 65 67 69 n)). (begi
1f70: 6e 0a 09 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f n.. ;; (mutex-lo
1f80: 63 6b 21 20 2a 73 65 6e 64 2d 6d 75 74 65 78 2a ck! *send-mutex*
1f90: 29 20 3b 3b 20 44 4f 45 53 4e 27 54 20 53 45 45 ) ;; DOESN'T SEE
1fa0: 4d 20 54 4f 20 48 45 4c 50 0a 09 20 28 6c 65 74 M TO HELP.. (let
1fb0: 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 6f -values (((inp o
1fc0: 75 70 29 28 74 63 70 2d 63 6f 6e 6e 65 63 74 20 up)(tcp-connect
1fd0: 68 6f 73 74 20 70 6f 72 74 29 29 29 0a 09 20 20 host port)))..
1fe0: 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 66 20 (let ((res (if
1ff0: 28 61 6e 64 20 69 6e 70 20 6f 75 70 29 0a 09 09 (and inp oup)...
2000: 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 . (begin....
2010: 20 28 77 72 69 74 65 20 28 6f 62 6a 2d 3e 73 74 (write (obj->st
2020: 72 69 6e 67 20 64 61 74 29 20 6f 75 70 29 20 3b ring dat) oup) ;
2030: 3b 20 28 77 72 69 74 65 20 64 61 74 20 6f 75 70 ; (write dat oup
2040: 29 3b 3b 20 28 73 65 72 69 61 6c 69 7a 65 20 64 );; (serialize d
2050: 61 74 20 6f 75 70 29 0a 09 09 09 20 20 20 20 28 at oup).... (
2060: 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
2070: 74 20 6f 75 70 29 0a 09 09 09 20 20 20 20 28 73 t oup).... (s
2080: 74 72 69 6e 67 2d 3e 6f 62 6a 20 28 72 65 61 64 tring->obj (read
2090: 20 69 6e 70 29 29 29 20 3b 3b 20 28 64 65 73 65 inp))) ;; (dese
20a0: 72 69 61 6c 69 7a 65 20 69 6e 70 29 29 0a 09 09 rialize inp))...
20b0: 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 . (begin....
20c0: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
20d0: 73 65 6e 64 20 63 61 6c 6c 65 64 20 62 75 74 20 send called but
20e0: 6e 6f 20 72 65 63 65 69 76 65 72 20 68 61 73 20 no receiver has
20f0: 62 65 65 6e 20 73 65 74 75 70 2e 20 50 6c 65 61 been setup. Plea
2100: 73 65 20 63 61 6c 6c 20 73 65 74 75 70 20 66 69 se call setup fi
2110: 72 73 74 21 22 29 0a 09 09 09 20 20 20 20 23 66 rst!").... #f
2120: 29 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 28 63 )))).. ;; (c
2130: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
2140: 20 6f 75 70 29 0a 09 20 20 20 20 20 28 63 6c 6f oup).. (clo
2150: 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e se-input-port in
2160: 70 29 0a 09 20 20 20 20 20 3b 3b 20 28 6d 75 74 p).. ;; (mut
2170: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 73 65 6e 64 ex-unlock! *send
2180: 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 44 4f 45 53 -mutex*) ;; DOES
2190: 4e 27 54 20 53 45 45 4d 20 54 4f 20 48 45 4c 50 N'T SEEM TO HELP
21a0: 0a 09 20 20 20 20 20 72 65 73 29 29 29 29 29 29 .. res))))))
21b0: 29 29 20 3b 3b 20 72 65 73 20 77 69 6c 6c 20 61 )) ;; res will a
21c0: 6c 77 61 79 73 20 62 65 20 27 61 63 6b 20 75 6e lways be 'ack un
21d0: 6c 65 73 73 20 72 65 74 75 72 6e 2d 6d 65 74 68 less return-meth
21e0: 6f 64 20 69 73 20 64 69 72 65 63 74 0a 0a 3b 3b od is direct..;;
21f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2230: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 77 6f 72 6b 20 71 ======.;; work q
2240: 75 65 75 65 73 20 2d 20 74 68 69 73 20 69 73 20 ueues - this is
2250: 61 6c 6c 20 68 61 70 70 65 6e 69 6e 67 20 6f 6e all happening on
2260: 20 74 68 65 20 6c 69 73 74 65 6e 65 72 20 73 69 the listener si
2270: 64 65 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d de.;;===========
2280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
22c0: 6d 6f 76 65 20 74 68 65 20 6c 6f 67 69 63 20 74 move the logic t
22d0: 6f 20 72 65 74 75 72 6e 20 74 68 65 20 72 65 73 o return the res
22e0: 75 6c 74 20 73 6f 6d 65 77 68 65 72 65 20 65 6c ult somewhere el
22f0: 73 65 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 se?.;;.(define (
2300: 64 6f 2d 77 6f 72 6b 20 75 63 6f 6e 6e 20 72 64 do-work uconn rd
2310: 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 29 20 3b at). (let* () ;
2320: 3b 20 67 65 74 20 69 74 20 65 61 63 68 20 74 69 ; get it each ti
2330: 6d 65 20 2d 20 63 6f 6e 63 65 69 76 65 62 6c 79 me - conceivebly
2340: 20 69 74 20 63 6f 75 6c 64 20 63 68 61 6e 67 65 it could change
2350: 0a 20 20 20 20 3b 3b 20 70 75 74 20 74 68 69 73 . ;; put this
2360: 20 66 6f 6c 6c 6f 77 69 6e 67 20 69 6e 74 6f 20 following into
2370: 61 20 64 6f 2d 77 6f 72 6b 20 70 72 6f 63 65 64 a do-work proced
2380: 75 72 65 0a 20 20 20 20 28 6d 61 74 63 68 20 72 ure. (match r
2390: 64 61 74 0a 20 20 20 20 20 20 28 28 72 65 6d 2d dat. ((rem-
23a0: 68 6f 73 74 2d 70 6f 72 74 20 71 72 79 6b 65 79 host-port qrykey
23b0: 20 63 6d 64 20 70 61 72 61 6d 73 29 0a 20 20 20 cmd params).
23c0: 20 20 20 20 28 63 61 73 65 20 63 6d 64 0a 09 20 (case cmd..
23d0: 28 28 70 69 6e 67 29 20 27 70 69 6e 67 2d 61 63 ((ping) 'ping-ac
23e0: 6b 29 20 3b 3b 20 62 79 70 61 73 73 20 63 61 6c k) ;; bypass cal
23f0: 6c 69 6e 67 20 74 68 65 20 70 72 6f 63 0a 09 20 ling the proc..
2400: 28 65 6c 73 65 0a 09 20 20 28 6c 65 74 2a 20 28 (else.. (let* (
2410: 28 70 72 6f 63 20 20 20 20 20 20 20 28 75 64 61 (proc (uda
2420: 74 2d 77 6f 72 6b 2d 70 72 6f 63 20 75 63 6f 6e t-work-proc ucon
2430: 6e 29 29 0a 09 09 20 28 73 74 61 72 74 2d 74 69 n))... (start-ti
2440: 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c me (current-mill
2450: 69 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 28 72 iseconds))... (r
2460: 65 73 75 6c 74 20 20 20 20 20 28 70 72 6f 63 20 esult (proc
2470: 72 65 6d 2d 68 6f 73 74 2d 70 6f 72 74 20 71 72 rem-host-port qr
2480: 79 6b 65 79 20 63 6d 64 20 70 61 72 61 6d 73 29 ykey cmd params)
2490: 29 0a 09 09 20 28 65 6e 64 2d 74 69 6d 65 20 20 )... (end-time
24a0: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
24b0: 65 63 6f 6e 64 73 29 29 0a 09 09 20 28 72 75 6e econds))... (run
24c0: 2d 74 69 6d 65 20 20 20 28 2d 20 65 6e 64 2d 74 -time (- end-t
24d0: 69 6d 65 20 73 74 61 72 74 2d 74 69 6d 65 29 29 ime start-time))
24e0: 29 0a 09 20 20 20 20 72 65 73 75 6c 74 29 29 29 ).. result)))
24f0: 29 0a 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 ). (else.
2500: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 (print "ERR
2510: 4f 52 3a 20 72 64 61 74 20 22 72 64 61 74 22 2c OR: rdat "rdat",
2520: 20 64 69 64 20 6e 6f 74 20 6d 61 74 63 68 20 72 did not match r
2530: 65 6d 2d 68 6f 73 74 2d 70 6f 72 74 20 71 72 79 em-host-port qry
2540: 6b 65 79 20 63 6d 64 20 70 61 72 61 6d 73 22 29 key cmd params")
2550: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
2560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
25a0: 3b 20 6d 69 73 63 20 75 74 69 6c 73 0a 3b 3b 3d ; misc utils.;;=
25b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25f0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
2600: 70 70 2d 75 63 6f 6e 6e 20 75 63 6f 6e 6e 29 0a pp-uconn uconn).
2610: 20 20 28 70 70 20 28 75 64 61 74 2d 3e 61 6c 69 (pp (udat->ali
2620: 73 74 20 75 63 6f 6e 6e 29 29 29 0a 0a 3b 3b 3d st uconn)))..;;=
2630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2670: 3d 3d 3d 3d 3d 0a 3b 3b 20 6e 65 74 77 6f 72 6b =====.;; network
2680: 20 75 74 69 6c 69 74 69 65 73 0a 3b 3b 3d 3d 3d utilities.;;===
2690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26d0: 3d 3d 3d 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 4c 6f ===..;; NOTE: Lo
26e0: 6f 6b 20 61 74 20 61 64 64 72 65 73 73 2d 69 6e ok at address-in
26f0: 66 6f 20 65 67 67 20 61 73 20 61 6c 74 65 72 6e fo egg as altern
2700: 61 74 69 76 65 20 74 6f 20 73 6f 6d 65 20 6f 66 ative to some of
2710: 20 74 68 69 73 0a 0a 28 64 65 66 69 6e 65 20 28 this..(define (
2720: 72 61 74 65 2d 69 70 20 69 70 61 64 64 72 29 0a rate-ip ipaddr).
2730: 20 20 28 72 65 67 65 78 2d 63 61 73 65 20 69 70 (regex-case ip
2740: 61 64 64 72 0a 20 20 20 20 28 20 22 5e 31 32 37 addr. ( "^127
2750: 5c 5c 2e 2e 2a 22 20 5f 20 30 20 29 0a 20 20 20 \\..*" _ 0 ).
2760: 20 28 20 22 5e 28 31 30 5c 5c 2e 30 7c 31 39 32 ( "^(10\\.0|192
2770: 5c 5c 2e 31 36 38 29 5c 5c 2e 2e 2a 22 20 5f 20 \\.168)\\..*" _
2780: 31 20 29 0a 20 20 20 20 28 20 65 6c 73 65 20 32 1 ). ( else 2
2790: 20 29 20 29 29 0a 0a 3b 3b 20 43 68 61 6e 67 65 ) ))..;; Change
27a0: 20 74 68 69 73 20 74 6f 20 62 69 61 73 20 66 6f this to bias fo
27b0: 72 20 61 64 64 72 65 73 73 65 73 20 77 69 74 68 r addresses with
27c0: 20 61 20 72 65 61 73 6f 6e 61 62 6c 65 20 62 72 a reasonable br
27d0: 6f 61 64 63 61 73 74 20 76 61 6c 75 65 3f 0a 3b oadcast value?.;
27e0: 3b 0a 28 64 65 66 69 6e 65 20 28 69 70 2d 70 72 ;.(define (ip-pr
27f0: 65 66 2d 6c 65 73 73 3f 20 61 20 62 29 0a 20 20 ef-less? a b).
2800: 28 3e 20 28 72 61 74 65 2d 69 70 20 61 29 20 28 (> (rate-ip a) (
2810: 72 61 74 65 2d 69 70 20 62 29 29 29 0a 0a 28 64 rate-ip b)))..(d
2820: 65 66 69 6e 65 20 28 67 65 74 2d 6d 79 2d 62 65 efine (get-my-be
2830: 73 74 2d 61 64 64 72 65 73 73 29 0a 20 20 28 6c st-address). (l
2840: 65 74 20 28 28 61 6c 6c 2d 6d 79 2d 61 64 64 72 et ((all-my-addr
2850: 65 73 73 65 73 20 28 67 65 74 2d 61 6c 6c 2d 69 esses (get-all-i
2860: 70 73 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a ps))). (cond.
2870: 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 61 6c 6c ((null? all
2880: 2d 6d 79 2d 61 64 64 72 65 73 73 65 73 29 0a 20 -my-addresses).
2890: 20 20 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e (get-host-n
28a0: 61 6d 65 29 29 20 20 20 20 20 20 20 20 20 20 20 ame))
28b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
28d0: 3b 20 6e 6f 20 69 6e 74 65 72 66 61 63 65 73 3f ; no interfaces?
28e0: 0a 20 20 20 20 20 28 28 65 71 3f 20 28 6c 65 6e . ((eq? (len
28f0: 67 74 68 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 gth all-my-addre
2900: 73 73 65 73 29 20 31 29 0a 20 20 20 20 20 20 28 sses) 1). (
2910: 63 61 72 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 car all-my-addre
2920: 73 73 65 73 29 29 20 20 20 20 20 20 20 20 20 20 sses))
2930: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f ;; o
2940: 6e 6c 79 20 6f 6e 65 20 74 6f 20 63 68 6f 6f 73 nly one to choos
2950: 65 20 66 72 6f 6d 2c 20 6a 75 73 74 20 67 6f 20 e from, just go
2960: 77 69 74 68 20 69 74 0a 20 20 20 20 20 28 65 6c with it. (el
2970: 73 65 0a 20 20 20 20 20 20 28 63 61 72 20 28 73 se. (car (s
2980: 6f 72 74 20 61 6c 6c 2d 6d 79 2d 61 64 64 72 65 ort all-my-addre
2990: 73 73 65 73 20 69 70 2d 70 72 65 66 2d 6c 65 73 sses ip-pref-les
29a0: 73 3f 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e s?))))))..(defin
29b0: 65 20 28 67 65 74 2d 61 6c 6c 2d 69 70 73 2d 73 e (get-all-ips-s
29c0: 6f 72 74 65 64 29 0a 20 20 28 73 6f 72 74 20 28 orted). (sort (
29d0: 67 65 74 2d 61 6c 6c 2d 69 70 73 29 20 69 70 2d get-all-ips) ip-
29e0: 70 72 65 66 2d 6c 65 73 73 3f 29 29 0a 0a 28 64 pref-less?))..(d
29f0: 65 66 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 69 efine (get-all-i
2a00: 70 73 29 0a 20 20 28 6d 61 70 20 61 64 64 72 65 ps). (map addre
2a10: 73 73 2d 69 6e 66 6f 2d 68 6f 73 74 0a 20 20 20 ss-info-host.
2a20: 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d (filter (lam
2a30: 62 64 61 20 28 78 29 0a 09 09 20 28 65 71 75 61 bda (x)... (equa
2a40: 6c 3f 20 28 61 64 64 72 65 73 73 2d 69 6e 66 6f l? (address-info
2a50: 2d 74 79 70 65 20 78 29 20 22 74 63 70 22 29 29 -type x) "tcp"))
2a60: 0a 09 20 20 20 20 20 20 20 28 61 64 64 72 65 73 .. (addres
2a70: 73 2d 69 6e 66 6f 73 20 28 67 65 74 2d 68 6f 73 s-infos (get-hos
2a80: 74 2d 6e 61 6d 65 29 29 29 29 29 0a 0a 29 0a t-name)))))..).