Artifact
397cba74a44e994c994138ed82d967dd9bb81f5e:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 28 72 65 71 75 PURPOSE...(requ
0150: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
0160: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
0170: 63 70 20 73 31 31 6e 29 0a 0a 28 75 73 65 20 73 cp s11n)..(use s
0180: 71 6c 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f qlite3 srfi-1 po
0190: 73 69 78 20 72 65 67 65 78 20 72 65 67 65 78 2d six regex regex-
01a0: 63 61 73 65 20 73 72 66 69 2d 36 39 20 68 6f 73 case srfi-69 hos
01b0: 74 69 6e 66 6f 20 6d 64 35 20 6d 65 73 73 61 67 tinfo md5 messag
01c0: 65 2d 64 69 67 65 73 74 29 0a 28 69 6d 70 6f 72 e-digest).(impor
01d0: 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 t (prefix sqlite
01e0: 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 0a 28 75 3 sqlite3:))..(u
01f0: 73 65 20 7a 6d 71 29 0a 0a 28 64 65 63 6c 61 72 se zmq)..(declar
0200: 65 20 28 75 6e 69 74 20 7a 6d 71 2d 74 72 61 6e e (unit zmq-tran
0210: 73 70 6f 72 74 29 29 0a 0a 28 64 65 63 6c 61 72 sport))..(declar
0220: 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 e (uses common))
0230: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0240: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0250: 73 65 73 20 74 65 73 74 73 29 29 0a 28 64 65 63 ses tests)).(dec
0260: 6c 61 72 65 20 28 75 73 65 73 20 74 61 73 6b 73 lare (uses tasks
0270: 29 29 20 3b 3b 20 74 61 73 6b 73 20 61 72 65 20 )) ;; tasks are
0280: 77 68 65 72 65 20 73 74 75 66 66 20 69 73 20 6d where stuff is m
0290: 61 69 6e 74 61 69 6e 65 64 20 61 62 6f 75 74 20 aintained about
02a0: 77 68 61 74 20 69 73 20 72 75 6e 6e 69 6e 67 2e what is running.
02b0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
02c0: 73 65 72 76 65 72 29 29 0a 0a 28 69 6e 63 6c 75 server))..(inclu
02d0: 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 de "common_recor
02e0: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
02f0: 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 e "db_records.sc
0300: 6d 22 29 0a 0a 3b 3b 20 54 72 61 6e 73 69 74 69 m")..;; Transiti
0310: 6f 6e 20 74 6f 20 70 75 62 20 2d 2d 3e 20 73 75 on to pub --> su
0320: 62 20 77 69 74 68 20 70 75 6c 6c 20 3c 2d 2d 20 b with pull <--
0330: 70 75 73 68 0a 3b 3b 0a 3b 3b 20 20 20 31 2e 20 push.;;.;; 1.
0340: 63 6c 69 65 6e 74 20 73 65 6e 64 73 20 72 65 71 client sends req
0350: 75 65 73 74 20 74 6f 20 73 65 72 76 65 72 20 76 uest to server v
0360: 69 61 20 70 75 73 68 20 74 6f 20 74 68 65 20 70 ia push to the p
0370: 75 6c 6c 20 70 6f 72 74 0a 3b 3b 20 20 20 32 2e ull port.;; 2.
0380: 20 73 65 72 76 65 72 20 70 75 74 73 20 72 65 71 server puts req
0390: 75 65 73 74 20 69 6e 20 71 75 65 75 65 20 6f 72 uest in queue or
03a0: 20 70 72 6f 63 65 73 73 65 73 20 69 6d 6d 65 64 processes immed
03b0: 69 61 74 65 6c 79 20 61 73 20 61 70 70 72 6f 70 iately as approp
03c0: 72 69 61 74 65 0a 3b 3b 20 20 20 33 2e 20 73 65 riate.;; 3. se
03d0: 72 76 65 72 20 70 75 74 73 20 72 65 73 70 6f 6e rver puts respon
03e0: 73 65 73 20 66 72 6f 6d 20 63 6f 6d 70 6c 65 74 ses from complet
03f0: 65 64 20 72 65 71 75 65 73 74 73 20 69 6e 74 6f ed requests into
0400: 20 70 75 62 20 70 6f 72 74 20 0a 3b 3b 0a 3b 3b pub port .;;.;;
0410: 20 54 4f 44 4f 0a 3b 3b 0a 3b 3b 20 44 6f 6e 65 TODO.;;.;; Done
0420: 20 54 65 73 74 65 64 0a 3b 3b 20 5b 78 5d 20 20 Tested.;; [x]
0430: 5b 20 5d 20 20 20 20 31 2e 20 41 64 64 20 63 6f [ ] 1. Add co
0440: 6c 75 6d 6e 73 20 70 75 6c 6c 70 6f 72 74 20 70 lumns pullport p
0450: 75 62 70 6f 72 74 20 74 6f 20 73 65 72 76 65 72 ubport to server
0460: 73 20 74 61 62 6c 65 0a 3b 3b 20 5b 78 5d 20 20 s table.;; [x]
0470: 5b 20 5d 20 20 20 20 32 2e 20 41 64 64 20 72 6d [ ] 2. Add rm
0480: 20 6f 66 20 6d 6f 6e 69 74 6f 72 2e 64 62 20 69 of monitor.db i
0490: 66 20 6f 6c 64 65 72 20 74 68 61 6e 20 31 31 2f f older than 11/
04a0: 31 32 2f 32 30 31 32 20 0a 3b 3b 20 5b 78 5d 20 12/2012 .;; [x]
04b0: 20 5b 20 5d 20 20 20 20 33 2e 20 41 64 64 20 63 [ ] 3. Add c
04c0: 72 65 61 74 65 20 6f 66 20 70 75 6c 6c 70 6f 72 reate of pullpor
04d0: 74 20 61 6e 64 20 70 75 62 70 6f 72 74 20 77 69 t and pubport wi
04e0: 74 68 20 66 69 6e 64 69 6e 67 20 6f 66 20 61 76 th finding of av
04f0: 61 69 6c 61 62 6c 65 20 70 6f 72 74 73 0a 3b 3b ailable ports.;;
0500: 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 34 2e 20 [x] [ ] 4.
0510: 41 64 64 20 63 6c 69 65 6e 74 20 63 6f 6d 70 6f Add client compo
0520: 73 65 20 6f 66 20 72 65 71 75 65 73 74 0a 3b 3b se of request.;;
0530: 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 20 20 20 [x] [ ]
0540: 20 2d 20 6e 61 6d 65 20 6f 66 20 63 6c 69 65 6e - name of clien
0550: 74 3a 20 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d t: testname/item
0560: 70 61 74 68 2d 74 65 73 74 5f 69 64 2d 68 6f 73 path-test_id-hos
0570: 74 6e 61 6d 65 20 0a 3b 3b 20 5b 78 5d 20 20 5b tname .;; [x] [
0580: 20 5d 20 20 20 20 20 20 20 20 2d 20 6e 61 6d 65 ] - name
0590: 20 6f 66 20 72 65 71 75 65 73 74 3a 20 63 61 6c of request: cal
05a0: 6c 6e 61 6d 65 2c 20 70 61 72 61 6d 73 0a 3b 3b lname, params.;;
05b0: 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 20 20 20 [x] [ ]
05c0: 20 2d 20 72 65 71 75 65 73 74 20 6b 65 79 3a 20 - request key:
05d0: 66 28 63 6c 69 65 6e 74 6e 61 6d 65 2c 20 63 61 f(clientname, ca
05e0: 6c 6c 6e 61 6d 65 2c 20 70 61 72 61 6d 73 29 0a llname, params).
05f0: 3b 3b 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 35 ;; [x] [ ] 5
0600: 2e 20 41 64 64 20 70 72 6f 63 65 73 73 69 6e 67 . Add processing
0610: 20 6f 66 20 73 75 62 73 63 72 69 70 74 69 6f 6e of subscription
0620: 20 68 69 74 73 0a 3b 3b 20 5b 78 5d 20 20 5b 20 hits.;; [x] [
0630: 5d 20 20 20 20 20 20 20 20 2d 20 64 6f 6e 65 20 ] - done
0640: 77 68 65 6e 20 67 65 74 20 6b 65 79 20 0a 3b 3b when get key .;;
0650: 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 20 20 20 [x] [ ]
0660: 20 2d 20 72 65 74 75 72 6e 20 72 65 73 75 6c 74 - return result
0670: 73 0a 3b 3b 20 5b 78 5d 20 20 5b 20 5d 20 20 20 s.;; [x] [ ]
0680: 20 36 2e 20 41 64 64 20 74 69 6d 65 6f 75 74 20 6. Add timeout
0690: 70 72 6f 63 65 73 73 69 6e 67 0a 3b 3b 20 5b 78 processing.;; [x
06a0: 5d 20 20 5b 20 5d 20 20 20 20 20 20 20 20 2d 20 ] [ ] -
06b0: 61 66 74 65 72 20 36 30 20 73 65 63 6f 6e 64 73 after 60 seconds
06c0: 0a 3b 3b 20 5b 20 5d 20 20 5b 20 5d 20 20 20 20 .;; [ ] [ ]
06d0: 20 20 20 20 20 20 20 20 69 2e 20 63 68 65 63 6b i. check
06e0: 20 73 65 72 76 65 72 20 61 6c 69 76 65 2c 20 63 server alive, c
06f0: 6f 6e 6e 65 63 74 20 74 6f 20 6e 65 77 20 69 66 onnect to new if
0700: 20 6e 65 63 65 73 73 61 72 79 0a 3b 3b 20 5b 20 necessary.;; [
0710: 5d 20 20 5b 20 5d 20 20 20 20 20 20 20 20 20 20 ] [ ]
0720: 20 69 69 2e 20 72 65 73 65 6e 64 20 72 65 71 75 ii. resend requ
0730: 65 73 74 0a 3b 3b 20 5b 20 5d 20 20 5b 20 5d 20 est.;; [ ] [ ]
0740: 20 20 20 37 2e 20 54 75 72 6e 20 73 65 6c 66 20 7. Turn self
0750: 70 69 6e 67 20 62 61 63 6b 20 6f 6e 0a 0a 28 64 ping back on..(d
0760: 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 6e 73 efine (zmq-trans
0770: 70 6f 72 74 3a 6d 61 6b 65 2d 73 65 72 76 65 72 port:make-server
0780: 2d 75 72 6c 20 68 6f 73 74 70 6f 72 74 29 0a 20 -url hostport).
0790: 20 28 69 66 20 28 6e 6f 74 20 68 6f 73 74 70 6f (if (not hostpo
07a0: 72 74 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 rt). #f.
07b0: 20 20 20 28 63 6f 6e 63 20 22 74 63 70 3a 2f 2f (conc "tcp://
07c0: 22 20 28 63 61 72 20 68 6f 73 74 70 6f 72 74 29 " (car hostport)
07d0: 20 22 3a 22 20 28 63 61 64 72 20 68 6f 73 74 70 ":" (cadr hostp
07e0: 6f 72 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ort))))..(define
07f0: 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 *server-loop-he
0800: 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 72 65 art-beat* (curre
0810: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 28 64 65 nt-seconds)).(de
0820: 66 69 6e 65 20 2a 68 65 61 72 74 62 65 61 74 2d fine *heartbeat-
0830: 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 mutex* (make-mut
0840: 65 78 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ex))..;;========
0850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
0890: 3b 20 53 20 45 20 52 20 56 20 45 20 52 0a 3b 3b ; S E R V E R.;;
08a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08e0: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 2d ======..(define-
08f0: 69 6e 6c 69 6e 65 20 28 7a 6d 71 73 6f 63 6b 3a inline (zmqsock:
0900: 67 65 74 2d 70 75 62 20 20 64 61 74 29 28 76 65 get-pub dat)(ve
0910: 63 74 6f 72 2d 72 65 66 20 64 61 74 20 30 29 29 ctor-ref dat 0))
0920: 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 .(define-inline
0930: 28 7a 6d 71 73 6f 63 6b 3a 67 65 74 2d 70 75 6c (zmqsock:get-pul
0940: 6c 20 64 61 74 29 28 76 65 63 74 6f 72 2d 72 65 l dat)(vector-re
0950: 66 20 64 61 74 20 31 29 29 0a 28 64 65 66 69 6e f dat 1)).(defin
0960: 65 2d 69 6e 6c 69 6e 65 20 28 7a 6d 71 73 6f 63 e-inline (zmqsoc
0970: 6b 3a 73 65 74 2d 70 75 62 21 20 64 61 74 20 73 k:set-pub! dat s
0980: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 64 61 )(vector-set! da
0990: 74 20 73 20 30 29 29 0a 28 64 65 66 69 6e 65 2d t s 0)).(define-
09a0: 69 6e 6c 69 6e 65 20 28 7a 6d 71 73 6f 63 6b 3a inline (zmqsock:
09b0: 73 65 74 2d 70 75 6c 6c 21 20 64 61 74 20 73 29 set-pull! dat s)
09c0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 64 61 74 (vector-set! dat
09d0: 20 73 20 30 29 29 0a 0a 28 64 65 66 69 6e 65 20 s 0))..(define
09e0: 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 72 (zmq-transport:r
09f0: 75 6e 20 68 6f 73 74 6e 29 0a 20 20 28 64 65 62 un hostn). (deb
0a00: 75 67 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 ug:print 2 "Atte
0a10: 6d 70 74 69 6e 67 20 74 6f 20 73 74 61 72 74 20 mpting to start
0a20: 74 68 65 20 73 65 72 76 65 72 20 2e 2e 2e 22 29 the server ...")
0a30: 0a 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 6f 70 . (if (not *top
0a40: 70 61 74 68 2a 29 0a 20 20 20 20 20 20 28 69 66 path*). (if
0a50: 20 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 (not (setup-for
0a60: 2d 72 75 6e 29 29 0a 09 20 20 28 62 65 67 69 6e -run)).. (begin
0a70: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
0a80: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 63 61 6e nt 0 "ERROR: can
0a90: 6e 6f 74 20 66 69 6e 64 20 6d 65 67 61 74 65 73 not find megates
0aa0: 74 2e 63 6f 6e 66 69 67 2c 20 63 61 6e 6e 6f 74 t.config, cannot
0ab0: 20 73 74 61 72 74 20 73 65 72 76 65 72 2c 20 65 start server, e
0ac0: 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 28 65 xiting").. (e
0ad0: 78 69 74 29 29 29 29 0a 20 20 28 6c 65 74 2a 20 xit)))). (let*
0ae0: 28 28 64 62 20 20 20 20 20 20 20 20 20 20 20 20 ((db
0af0: 20 20 28 6f 70 65 6e 2d 64 62 29 29 20 3b 3b 20 (open-db)) ;;
0b00: 68 65 72 65 20 77 65 20 2a 64 6f 20 6e 6f 74 2a here we *do not*
0b10: 20 77 61 6e 74 20 74 6f 20 62 65 20 6f 70 65 6e want to be open
0b20: 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 20 ing and closing
0b30: 74 68 65 20 64 62 0a 09 20 28 7a 6d 71 2d 73 64 the db.. (zmq-sd
0b40: 61 74 31 20 20 20 20 20 20 20 23 66 29 0a 09 20 at1 #f)..
0b50: 28 7a 6d 71 2d 73 64 61 74 32 20 20 20 20 20 20 (zmq-sdat2
0b60: 20 23 66 29 0a 09 20 28 70 75 6c 6c 2d 73 6f 63 #f).. (pull-soc
0b70: 6b 65 74 20 20 20 20 20 23 66 29 0a 09 20 28 70 ket #f).. (p
0b80: 75 62 2d 73 6f 63 6b 65 74 20 20 20 20 20 20 23 ub-socket #
0b90: 66 29 0a 09 20 28 70 31 20 20 20 20 20 20 20 20 f).. (p1
0ba0: 20 20 20 20 20 20 23 66 29 0a 09 20 28 70 32 20 #f).. (p2
0bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
0bc0: 0a 09 20 28 7a 6d 71 2d 73 6f 63 6b 65 74 73 2d .. (zmq-sockets-
0bd0: 64 61 74 20 23 66 29 0a 09 20 28 69 66 61 63 65 dat #f).. (iface
0be0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
0bf0: 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 string=? "-" hos
0c00: 74 6e 29 0a 09 09 09 20 20 20 20 20 20 22 2a 22 tn).... "*"
0c10: 20 3b 3b 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 ;; (get-host-na
0c20: 6d 65 29 20 0a 09 09 09 20 20 20 20 20 20 68 6f me) .... ho
0c30: 73 74 6e 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d stn)).. (hostnam
0c40: 65 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 6f e (get-ho
0c50: 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 st-name)).. (ipa
0c60: 64 64 72 73 74 72 20 20 20 20 20 20 20 28 6c 65 ddrstr (le
0c70: 74 20 28 28 69 70 73 74 72 20 28 69 66 20 28 73 t ((ipstr (if (s
0c80: 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 74 tring=? "-" host
0c90: 6e 29 0a 09 09 09 09 09 20 20 20 28 73 74 72 69 n)...... (stri
0ca0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
0cb0: 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 map number->stri
0cc0: 6e 67 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 ng (u8vector->li
0cd0: 73 74 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 st (hostname->ip
0ce0: 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 22 2e 22 hostname))) "."
0cf0: 29 0a 09 09 09 09 09 20 20 20 23 66 29 29 29 0a )...... #f))).
0d00: 09 09 09 20 20 20 20 28 69 66 20 69 70 73 74 72 ... (if ipstr
0d10: 20 69 70 73 74 72 20 68 6f 73 74 6e 61 6d 65 29 ipstr hostname)
0d20: 29 29 0a 09 20 28 6c 61 73 74 2d 72 75 6e 20 20 )).. (last-run
0d30: 20 20 20 20 20 30 29 29 0a 20 20 20 20 28 73 65 0)). (se
0d40: 74 21 20 7a 6d 71 2d 73 6f 63 6b 65 74 73 2d 64 t! zmq-sockets-d
0d50: 61 74 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 at (zmq-transpor
0d60: 74 3a 73 65 74 75 70 2d 70 6f 72 74 73 20 69 70 t:setup-ports ip
0d70: 61 64 64 72 73 74 72 20 28 69 66 20 28 61 72 67 addrstr (if (arg
0d80: 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 6f 72 74 s:get-arg "-port
0d90: 22 29 0a 09 09 09 20 20 20 20 28 73 74 72 69 6e ").... (strin
0da0: 67 2d 3e 6e 75 6d 62 65 72 20 28 61 72 67 73 3a g->number (args:
0db0: 67 65 74 2d 61 72 67 20 22 2d 70 6f 72 74 22 29 get-arg "-port")
0dc0: 29 0a 09 09 09 09 09 09 09 20 20 20 20 28 2b 20 )........ (+
0dd0: 35 30 30 30 20 28 72 61 6e 64 6f 6d 20 31 30 30 5000 (random 100
0de0: 31 29 29 29 29 29 0a 0a 20 20 20 20 28 73 65 74 1))))).. (set
0df0: 21 20 7a 6d 71 2d 73 64 61 74 31 20 20 20 20 28 ! zmq-sdat1 (
0e00: 63 61 72 20 20 20 7a 6d 71 2d 73 6f 63 6b 65 74 car zmq-socket
0e10: 73 2d 64 61 74 29 29 0a 20 20 20 20 28 73 65 74 s-dat)). (set
0e20: 21 20 70 75 6c 6c 2d 73 6f 63 6b 65 74 20 20 28 ! pull-socket (
0e30: 63 61 64 72 20 20 7a 6d 71 2d 73 64 61 74 31 29 cadr zmq-sdat1)
0e40: 29 20 3b 3b 20 28 69 66 61 63 65 20 73 20 20 70 ) ;; (iface s p
0e50: 6f 72 74 29 0a 20 20 20 20 28 73 65 74 21 20 70 ort). (set! p
0e60: 31 20 20 20 20 20 20 20 20 20 20 20 28 63 61 64 1 (cad
0e70: 64 72 20 7a 6d 71 2d 73 64 61 74 31 29 29 0a 20 dr zmq-sdat1)).
0e80: 20 20 20 0a 20 20 20 20 28 73 65 74 21 20 7a 6d . (set! zm
0e90: 71 2d 73 64 61 74 32 20 20 20 20 28 63 61 64 72 q-sdat2 (cadr
0ea0: 20 20 7a 6d 71 2d 73 6f 63 6b 65 74 73 2d 64 61 zmq-sockets-da
0eb0: 74 29 29 0a 20 20 20 20 28 73 65 74 21 20 70 75 t)). (set! pu
0ec0: 62 2d 73 6f 63 6b 65 74 20 20 20 28 63 61 64 72 b-socket (cadr
0ed0: 20 20 7a 6d 71 2d 73 64 61 74 32 29 29 0a 20 20 zmq-sdat2)).
0ee0: 20 20 28 73 65 74 21 20 70 32 20 20 20 20 20 20 (set! p2
0ef0: 20 20 20 20 20 28 63 61 64 64 72 20 7a 6d 71 2d (caddr zmq-
0f00: 73 64 61 74 32 29 29 0a 0a 20 20 20 20 28 73 65 sdat2)).. (se
0f10: 74 21 20 2a 63 61 63 68 65 2d 6f 6e 2a 20 23 74 t! *cache-on* #t
0f20: 29 0a 0a 20 20 20 20 28 73 65 74 21 20 2a 72 75 ).. (set! *ru
0f30: 6e 72 65 6d 6f 74 65 2a 20 28 76 65 63 74 6f 72 nremote* (vector
0f40: 20 70 75 6c 6c 2d 73 6f 63 6b 65 74 20 70 75 62 pull-socket pub
0f50: 2d 73 6f 63 6b 65 74 29 29 20 3b 3b 20 6f 76 65 -socket)) ;; ove
0f60: 72 6c 6f 61 64 69 6e 67 20 74 68 65 20 75 73 65 rloading the use
0f70: 20 6f 66 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 of *runremote*
0f80: 42 55 47 21 3f 0a 0a 20 20 20 20 3b 3b 20 77 68 BUG!?.. ;; wh
0f90: 61 74 20 74 6f 20 64 6f 20 77 68 65 6e 20 77 65 at to do when we
0fa0: 20 71 75 69 74 0a 20 20 20 20 3b 3b 0a 3b 3b 20 quit. ;;.;;
0fb0: 20 20 20 20 28 6f 6e 2d 65 78 69 74 20 28 6c 61 (on-exit (la
0fc0: 6d 62 64 61 20 28 29 0a 3b 3b 20 09 20 20 20 20 mbda ().;; .
0fd0: 20 20 20 28 69 66 20 28 61 6e 64 20 2a 74 6f 70 (if (and *top
0fe0: 70 61 74 68 2a 20 2a 73 65 72 76 65 72 2d 69 6e path* *server-in
0ff0: 66 6f 2a 29 0a 3b 3b 20 09 09 20 20 20 28 6f 70 fo*).;; .. (op
1000: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 en-run-close tas
1010: 6b 73 3a 73 65 72 76 65 72 2d 64 65 72 65 67 69 ks:server-deregi
1020: 73 74 65 72 2d 73 65 6c 66 20 74 61 73 6b 73 3a ster-self tasks:
1030: 6f 70 65 6e 2d 64 62 20 28 63 61 72 20 2a 73 65 open-db (car *se
1040: 72 76 65 72 2d 69 6e 66 6f 2a 29 29 0a 3b 3b 20 rver-info*)).;;
1050: 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 .. (let loop (
1060: 29 20 0a 3b 3b 20 09 09 20 20 20 20 20 28 6c 65 ) .;; .. (le
1070: 74 20 28 28 71 75 65 75 65 2d 6c 65 6e 20 30 29 t ((queue-len 0)
1080: 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 20 28 74 ).;; .. (t
1090: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 72 61 hread-sleep! (ra
10a0: 6e 64 6f 6d 20 35 29 29 0a 3b 3b 20 09 09 20 20 ndom 5)).;; ..
10b0: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
10c0: 21 20 2a 69 6e 63 6f 6d 69 6e 67 2d 6d 75 74 65 ! *incoming-mute
10d0: 78 2a 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 20 x*).;; ..
10e0: 28 73 65 74 21 20 71 75 65 75 65 2d 6c 65 6e 20 (set! queue-len
10f0: 28 6c 65 6e 67 74 68 20 2a 69 6e 63 6f 6d 69 6e (length *incomin
1100: 67 2d 64 61 74 61 2a 29 29 0a 3b 3b 20 09 09 20 g-data*)).;; ..
1110: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
1120: 6f 63 6b 21 20 2a 69 6e 63 6f 6d 69 6e 67 2d 6d ock! *incoming-m
1130: 75 74 65 78 2a 29 0a 3b 3b 20 09 09 20 20 20 20 utex*).;; ..
1140: 20 20 20 28 69 66 20 28 3e 20 71 75 65 75 65 2d (if (> queue-
1150: 6c 65 6e 20 30 29 0a 3b 3b 20 09 09 09 20 20 20 len 0).;; ...
1160: 28 62 65 67 69 6e 0a 3b 3b 20 09 09 09 20 20 20 (begin.;; ...
1170: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
1180: 6e 66 6f 20 30 20 22 51 75 65 75 65 20 6e 6f 74 nfo 0 "Queue not
1190: 20 66 6c 75 73 68 65 64 2c 20 77 61 69 74 69 6e flushed, waitin
11a0: 67 20 2e 2e 2e 22 29 0a 3b 3b 20 09 09 09 20 20 g ...").;; ...
11b0: 20 20 20 28 6c 6f 6f 70 29 29 29 29 29 29 29 29 (loop))))))))
11c0: 0a 0a 20 20 20 20 3b 3b 20 54 68 65 20 68 65 61 .. ;; The hea
11d0: 76 79 20 6c 69 66 74 69 6e 67 0a 20 20 20 20 3b vy lifting. ;
11e0: 3b 0a 20 20 20 20 3b 3b 20 6d 61 6b 65 2d 76 65 ;. ;; make-ve
11f0: 63 74 6f 72 2d 72 65 63 6f 72 64 20 63 64 62 20 ctor-record cdb
1200: 70 61 63 6b 65 74 20 63 6c 69 65 6e 74 2d 73 69 packet client-si
1210: 67 20 71 74 79 70 65 20 69 6d 6d 65 64 69 61 74 g qtype immediat
1220: 65 20 71 75 65 72 79 2d 73 69 67 20 70 61 72 61 e query-sig para
1230: 6d 73 20 71 74 69 6d 65 0a 20 20 20 20 3b 3b 0a ms qtime. ;;.
1240: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1250: 2d 69 6e 66 6f 20 31 31 20 22 53 65 72 76 65 72 -info 11 "Server
1260: 20 73 65 74 75 70 20 63 6f 6d 70 6c 65 74 65 2c setup complete,
1270: 20 73 74 61 72 74 20 6c 69 73 74 65 6e 69 6e 67 start listening
1280: 20 66 6f 72 20 6d 65 73 73 61 67 65 73 22 29 0a for messages").
1290: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
12a0: 71 75 65 75 65 2d 6c 73 74 20 27 28 29 29 29 0a queue-lst '())).
12b0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 61 (let* ((ra
12c0: 77 6d 73 67 20 28 72 65 63 65 69 76 65 2d 6d 65 wmsg (receive-me
12d0: 73 73 61 67 65 2a 20 70 75 6c 6c 2d 73 6f 63 6b ssage* pull-sock
12e0: 65 74 29 29 0a 09 20 20 20 20 20 28 70 61 63 6b et)).. (pack
12f0: 65 74 20 28 64 62 3a 73 74 72 69 6e 67 2d 3e 6f et (db:string->o
1300: 62 6a 20 72 61 77 6d 73 67 29 29 0a 09 20 20 20 bj rawmsg))..
1310: 20 20 28 71 74 79 70 65 20 20 28 63 64 62 3a 70 (qtype (cdb:p
1320: 61 63 6b 65 74 2d 67 65 74 2d 71 74 79 70 65 20 acket-get-qtype
1330: 70 61 63 6b 65 74 29 29 29 0a 09 28 64 65 62 75 packet)))..(debu
1340: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 g:print-info 12
1350: 22 73 65 72 76 65 72 3d 3e 20 72 65 63 65 69 76 "server=> receiv
1360: 65 64 20 70 61 63 6b 65 74 3d 22 20 70 61 63 6b ed packet=" pack
1370: 65 74 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 6d et)..(if (not (m
1380: 65 6d 62 65 72 20 71 74 79 70 65 20 27 28 73 79 ember qtype '(sy
1390: 6e 63 20 70 69 6e 67 29 29 29 0a 09 20 20 20 20 nc ping)))..
13a0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 6d (begin.. (m
13b0: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 utex-lock! *hear
13c0: 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 20 tbeat-mutex*)..
13d0: 20 20 20 20 20 28 73 65 74 21 20 2a 6c 61 73 74 (set! *last
13e0: 2d 64 62 2d 61 63 63 65 73 73 2a 20 28 63 75 72 -db-access* (cur
13f0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
1400: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
1410: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
1420: 6d 75 74 65 78 2a 29 29 29 0a 09 28 69 66 20 23 mutex*)))..(if #
1430: 74 20 3b 3b 20 28 63 64 62 3a 70 61 63 6b 65 74 t ;; (cdb:packet
1440: 2d 67 65 74 2d 69 6d 6d 65 64 69 61 74 65 20 70 -get-immediate p
1450: 61 63 6b 65 74 29 20 3b 3b 20 70 72 6f 63 65 73 acket) ;; proces
1460: 73 20 69 6d 6d 65 64 69 61 74 65 6c 79 20 6f 72 s immediately or
1470: 20 70 75 74 20 69 6e 20 71 75 65 75 65 0a 09 20 put in queue..
1480: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
1490: 20 28 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 (db:process-que
14a0: 75 65 2d 69 74 65 6d 20 64 62 20 70 61 63 6b 65 ue-item db packe
14b0: 74 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 6f 70 t).. ;; (op
14c0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
14d0: 70 72 6f 63 65 73 73 2d 71 75 65 75 65 20 23 66 process-queue #f
14e0: 20 70 75 62 2d 73 6f 63 6b 65 74 20 28 63 6f 6e pub-socket (con
14f0: 73 20 70 61 63 6b 65 74 20 71 75 65 75 65 2d 6c s packet queue-l
1500: 73 74 29 29 0a 09 20 20 20 20 20 20 0a 09 20 20 st)).. ..
1510: 20 20 20 20 28 6c 6f 6f 70 20 27 28 29 29 29 0a (loop '())).
1520: 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 6f 6e 73 . (loop (cons
1530: 20 70 61 63 6b 65 74 20 71 75 65 75 65 2d 6c 73 packet queue-ls
1540: 74 29 29 29 29 29 29 29 0a 0a 3b 3b 20 72 75 6e t)))))))..;; run
1550: 20 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 6b zmq-transport:k
1560: 65 65 70 2d 72 75 6e 6e 69 6e 67 20 69 6e 20 61 eep-running in a
1570: 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 parallel thread
1580: 20 74 6f 20 6d 6f 6e 69 74 6f 72 20 74 68 61 74 to monitor that
1590: 20 74 68 65 20 64 62 20 69 73 20 62 65 69 6e 67 the db is being
15a0: 20 0a 3b 3b 20 75 73 65 64 20 61 6e 64 20 74 6f .;; used and to
15b0: 20 73 68 75 74 64 6f 77 6e 20 61 66 74 65 72 20 shutdown after
15c0: 73 6f 6d 65 74 69 6d 65 20 69 66 20 69 74 20 69 sometime if it i
15d0: 73 20 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e s not..;;.(defin
15e0: 65 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 e (zmq-transport
15f0: 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 29 0a 20 :keep-running).
1600: 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 75 6e 6e ;; if none runn
1610: 69 6e 67 20 6f 72 20 69 66 20 3e 20 32 30 20 73 ing or if > 20 s
1620: 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 0a 20 20 econds since .
1630: 3b 3b 20 73 65 72 76 65 72 20 6c 61 73 74 20 75 ;; server last u
1640: 73 65 64 20 74 68 65 6e 20 73 74 61 72 74 20 73 sed then start s
1650: 68 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 68 69 hutdown. ;; Thi
1660: 73 20 74 68 72 65 61 64 20 77 61 69 74 73 20 66 s thread waits f
1670: 6f 72 20 74 68 65 20 73 65 72 76 65 72 20 74 6f or the server to
1680: 20 63 6f 6d 65 20 61 6c 69 76 65 0a 20 20 28 6c come alive. (l
1690: 65 74 2a 20 28 28 73 65 72 76 65 72 2d 69 6e 66 et* ((server-inf
16a0: 6f 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 09 o (let loop ()..
16b0: 09 09 28 6c 65 74 20 28 28 73 64 61 74 20 23 66 ..(let ((sdat #f
16c0: 29 29 0a 09 09 09 20 20 28 6d 75 74 65 78 2d 6c )).... (mutex-l
16d0: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
16e0: 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 28 73 65 mutex*).... (se
16f0: 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d t! sdat *server-
1700: 69 6e 66 6f 2a 29 0a 09 09 09 20 20 28 6d 75 74 info*).... (mut
1710: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 ex-unlock! *hear
1720: 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 09 tbeat-mutex*)...
1730: 09 20 20 28 69 66 20 73 64 61 74 20 73 64 61 74 . (if sdat sdat
1740: 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e .... (begin
1750: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
1760: 74 20 31 32 20 22 57 41 52 4e 49 4e 47 3a 20 73 t 12 "WARNING: s
1770: 65 72 76 65 72 20 6e 6f 74 20 73 74 61 72 74 65 erver not starte
1780: 64 20 79 65 74 2c 20 77 61 69 74 69 6e 67 20 66 d yet, waiting f
1790: 65 77 20 73 65 63 6f 6e 64 73 20 62 65 66 6f 72 ew seconds befor
17a0: 65 20 74 72 79 69 6e 67 20 61 67 61 69 6e 22 29 e trying again")
17b0: 0a 09 09 09 09 28 73 6c 65 65 70 20 34 29 0a 09 .....(sleep 4)..
17c0: 09 09 09 28 6c 6f 6f 70 29 29 29 29 29 29 0a 09 ...(loop))))))..
17d0: 20 28 69 66 61 63 65 20 20 20 20 20 20 20 28 63 (iface (c
17e0: 61 64 72 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 adr server-info)
17f0: 29 0a 09 20 28 70 75 6c 6c 70 6f 72 74 20 20 20 ).. (pullport
1800: 20 28 63 61 64 64 72 20 73 65 72 76 65 72 2d 69 (caddr server-i
1810: 6e 66 6f 29 29 0a 09 20 28 70 75 62 70 6f 72 74 nfo)).. (pubport
1820: 20 20 20 20 20 28 63 61 64 64 64 72 20 73 65 72 (cadddr ser
1830: 76 65 72 2d 69 6e 66 6f 29 29 20 3b 3b 20 69 64 ver-info)) ;; id
1840: 20 69 6e 74 65 72 66 61 63 65 20 70 75 6c 6c 70 interface pullp
1850: 6f 72 74 20 70 75 62 70 6f 72 74 29 0a 09 20 3b ort pubport).. ;
1860: 3b 20 28 7a 6d 71 2d 73 6f 63 6b 65 74 73 20 28 ; (zmq-sockets (
1870: 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c zmq-transport:cl
1880: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 ient-connect ifa
1890: 63 65 20 70 75 6c 6c 70 6f 72 74 20 70 75 62 70 ce pullport pubp
18a0: 6f 72 74 29 29 0a 09 20 28 6c 61 73 74 2d 61 63 ort)).. (last-ac
18b0: 63 65 73 73 20 30 29 29 0a 20 20 20 20 28 64 65 cess 0)). (de
18c0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
18d0: 31 20 22 68 65 61 72 74 62 65 61 74 20 73 74 61 1 "heartbeat sta
18e0: 72 74 65 64 20 66 6f 72 20 7a 6d 71 20 73 65 72 rted for zmq ser
18f0: 76 65 72 20 6f 6e 20 22 20 69 66 61 63 65 20 22 ver on " iface "
1900: 20 22 20 70 75 6c 6c 70 6f 72 74 20 22 20 22 20 " pullport " "
1910: 70 75 62 70 6f 72 74 29 0a 20 20 20 20 28 6c 65 pubport). (le
1920: 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 t loop ((count 0
1930: 29 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 )). (thread
1940: 2d 73 6c 65 65 70 21 20 34 29 20 3b 3b 20 6e 6f -sleep! 4) ;; no
1950: 20 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 need to do this
1960: 20 76 65 72 79 20 6f 66 74 65 6e 0a 20 20 20 20 very often.
1970: 20 20 3b 3b 20 4e 42 2f 2f 20 73 79 6e 63 20 63 ;; NB// sync c
1980: 75 72 72 65 6e 74 6c 79 20 64 6f 65 73 20 4e 4f urrently does NO
1990: 54 20 72 65 74 75 72 6e 20 71 75 65 75 65 2d 6c T return queue-l
19a0: 65 6e 67 74 68 0a 20 20 20 20 20 20 3b 3b 20 47 ength. ;; G
19b0: 45 54 20 52 45 41 4c 20 51 55 45 55 45 20 4c 45 ET REAL QUEUE LE
19c0: 4e 47 54 48 20 46 52 4f 4d 20 54 48 45 20 56 41 NGTH FROM THE VA
19d0: 52 49 41 42 4c 45 0a 20 20 20 20 20 20 28 6c 65 RIABLE. (le
19e0: 74 20 28 28 71 75 65 75 65 2d 6c 65 6e 20 30 29 t ((queue-len 0)
19f0: 29 20 3b 3b 20 46 4f 52 20 4e 4f 57 20 44 4f 20 ) ;; FOR NOW DO
1a00: 4e 4f 54 20 44 4f 20 54 48 49 53 20 28 63 64 62 NOT DO THIS (cdb
1a10: 3a 63 6c 69 65 6e 74 2d 63 61 6c 6c 20 7a 6d 71 :client-call zmq
1a20: 2d 73 6f 63 6b 65 74 73 20 27 73 79 6e 63 20 23 -sockets 'sync #
1a30: 74 20 31 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 t 1))). ;;
1a40: 28 70 72 69 6e 74 20 22 53 65 72 76 65 72 20 72 (print "Server r
1a50: 75 6e 6e 69 6e 67 2c 20 63 6f 75 6e 74 20 69 73 unning, count is
1a60: 20 22 20 63 6f 75 6e 74 29 0a 09 28 69 66 20 28 " count)..(if (
1a70: 3c 20 63 6f 75 6e 74 20 31 29 20 3b 3b 20 33 78 < count 1) ;; 3x
1a80: 33 20 3d 20 39 20 73 65 63 73 20 61 70 72 6f 78 3 = 9 secs aprox
1a90: 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 63 .. (loop (+ c
1aa0: 6f 75 6e 74 20 31 29 29 29 0a 0a 09 3b 3b 20 4e ount 1)))...;; N
1ab0: 4f 54 45 3a 20 47 65 74 20 72 69 64 20 6f 66 20 OTE: Get rid of
1ac0: 74 68 69 73 20 6d 65 63 68 61 6e 69 73 6d 21 20 this mechanism!
1ad0: 49 74 20 72 65 61 6c 6c 79 20 69 73 20 6e 6f 74 It really is not
1ae0: 20 6e 65 65 64 65 64 2e 2e 2e 0a 09 28 6f 70 65 needed.....(ope
1af0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b n-run-close task
1b00: 73 3a 73 65 72 76 65 72 2d 75 70 64 61 74 65 2d s:server-update-
1b10: 68 65 61 72 74 62 65 61 74 20 74 61 73 6b 73 3a heartbeat tasks:
1b20: 6f 70 65 6e 2d 64 62 20 28 63 61 72 20 73 65 72 open-db (car ser
1b30: 76 65 72 2d 69 6e 66 6f 29 29 0a 0a 09 3b 3b 20 ver-info))...;;
1b40: 28 69 66 20 3b 3b 20 28 6f 72 20 28 3e 20 6e 75 (if ;; (or (> nu
1b50: 6d 72 75 6e 6e 69 6e 67 20 30 29 20 3b 3b 20 73 mrunning 0) ;; s
1b60: 74 61 79 20 61 6c 69 76 65 20 66 6f 72 20 74 77 tay alive for tw
1b70: 6f 20 64 61 79 73 20 61 66 74 65 72 20 6c 61 73 o days after las
1b80: 74 20 61 63 63 65 73 73 0a 09 28 6d 75 74 65 78 t access..(mutex
1b90: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea
1ba0: 74 2d 6d 75 74 65 78 2a 29 0a 09 28 73 65 74 21 t-mutex*)..(set!
1bb0: 20 6c 61 73 74 2d 61 63 63 65 73 73 20 2a 6c 61 last-access *la
1bc0: 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 29 0a 09 st-db-access*)..
1bd0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
1be0: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
1bf0: 29 0a 09 28 69 66 20 28 3e 20 28 2b 20 6c 61 73 )..(if (> (+ las
1c00: 74 2d 61 63 63 65 73 73 0a 09 09 20 20 3b 3b 20 t-access... ;;
1c10: 28 2a 20 35 30 20 36 30 20 36 30 29 20 20 20 20 (* 50 60 60)
1c20: 3b 3b 20 34 38 20 68 72 73 0a 09 09 20 20 3b 3b ;; 48 hrs... ;;
1c30: 20 36 30 20 20 20 20 20 20 20 20 20 20 20 20 20 60
1c40: 20 3b 3b 20 6f 6e 65 20 6d 69 6e 75 74 65 0a 09 ;; one minute..
1c50: 09 20 20 3b 3b 20 28 2a 20 36 30 20 36 30 29 20 . ;; (* 60 60)
1c60: 20 20 20 20 20 20 3b 3b 20 6f 6e 65 20 68 6f 75 ;; one hou
1c70: 72 0a 09 09 20 20 28 2a 20 34 35 20 36 30 29 20 r... (* 45 60)
1c80: 20 20 20 20 20 20 20 20 20 3b 3b 20 34 35 20 6d ;; 45 m
1c90: 69 6e 75 74 65 73 2c 20 75 6e 74 69 6c 20 74 68 inutes, until th
1ca0: 65 20 64 62 20 64 65 6c 65 74 69 6f 6e 20 62 75 e db deletion bu
1cb0: 67 20 69 73 20 66 69 78 65 64 2e 0a 09 09 20 20 g is fixed....
1cc0: 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 65 ).. (curre
1cd0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 nt-seconds))..
1ce0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
1cf0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1d00: 6f 20 32 20 22 53 65 72 76 65 72 20 63 6f 6e 74 o 2 "Server cont
1d10: 69 6e 75 69 6e 67 2c 20 73 65 63 6f 6e 64 73 20 inuing, seconds
1d20: 73 69 6e 63 65 20 6c 61 73 74 20 64 62 20 61 63 since last db ac
1d30: 63 65 73 73 3a 20 22 20 28 2d 20 28 63 75 72 72 cess: " (- (curr
1d40: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 ent-seconds) las
1d50: 74 2d 61 63 63 65 73 73 29 29 0a 09 20 20 20 20 t-access))..
1d60: 20 20 28 6c 6f 6f 70 20 30 29 29 0a 09 20 20 20 (loop 0))..
1d70: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
1d80: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1d90: 20 30 20 22 53 74 61 72 74 69 6e 67 20 74 6f 20 0 "Starting to
1da0: 73 68 75 74 64 6f 77 6e 20 74 68 65 20 73 65 72 shutdown the ser
1db0: 76 65 72 2e 22 29 0a 09 20 20 20 20 20 20 3b 3b ver.").. ;;
1dc0: 20 6e 65 65 64 20 74 6f 20 64 65 6c 65 74 65 20 need to delete
1dd0: 6f 6e 6c 79 20 2a 6d 79 2a 20 73 65 72 76 65 72 only *my* server
1de0: 20 65 6e 74 72 79 20 28 66 75 74 75 72 65 20 75 entry (future u
1df0: 73 65 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 se).. (set!
1e00: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 *time-to-exit*
1e10: 23 74 29 0a 09 20 20 20 20 20 20 28 6f 70 65 6e #t).. (open
1e20: 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 -run-close tasks
1e30: 3a 73 65 72 76 65 72 2d 64 65 72 65 67 69 73 74 :server-deregist
1e40: 65 72 2d 73 65 6c 66 20 74 61 73 6b 73 3a 6f 70 er-self tasks:op
1e50: 65 6e 2d 64 62 20 28 67 65 74 2d 68 6f 73 74 2d en-db (get-host-
1e60: 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 28 74 name)).. (t
1e70: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
1e80: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
1e90: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4d 61 78 20 int-info 0 "Max
1ea0: 63 61 63 68 65 64 20 71 75 65 72 69 65 73 20 77 cached queries w
1eb0: 61 73 20 22 20 2a 6d 61 78 2d 63 61 63 68 65 2d as " *max-cache-
1ec0: 73 69 7a 65 2a 29 0a 09 20 20 20 20 20 20 28 64 size*).. (d
1ed0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1ee0: 30 20 22 53 65 72 76 65 72 20 73 68 75 74 64 6f 0 "Server shutdo
1ef0: 77 6e 20 63 6f 6d 70 6c 65 74 65 2e 20 45 78 69 wn complete. Exi
1f00: 74 69 6e 67 22 29 0a 09 20 20 20 20 20 20 28 65 ting").. (e
1f10: 78 69 74 29 29 29 29 29 29 29 0a 0a 28 64 65 66 xit)))))))..(def
1f20: 69 6e 65 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f ine (zmq-transpo
1f30: 72 74 3a 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 rt:find-free-por
1f40: 74 2d 61 6e 64 2d 6f 70 65 6e 20 69 66 61 63 65 t-and-open iface
1f50: 20 73 20 70 6f 72 74 20 73 74 79 70 65 20 23 21 s port stype #!
1f60: 6b 65 79 20 28 74 72 79 6e 75 6d 20 35 30 29 29 key (trynum 50))
1f70: 0a 20 20 28 6c 65 74 20 28 28 73 20 28 69 66 20 . (let ((s (if
1f80: 73 20 73 20 28 6d 61 6b 65 2d 73 6f 63 6b 65 74 s s (make-socket
1f90: 20 73 74 79 70 65 29 29 29 0a 20 20 20 20 20 20 stype))).
1fa0: 20 20 28 70 20 28 69 66 20 28 6e 75 6d 62 65 72 (p (if (number
1fb0: 3f 20 70 6f 72 74 29 20 70 6f 72 74 20 35 35 35 ? port) port 555
1fc0: 35 29 29 0a 20 20 20 20 20 20 20 20 28 6f 6c 64 5)). (old
1fd0: 2d 68 61 6e 64 6c 65 72 20 28 63 75 72 72 65 6e -handler (curren
1fe0: 74 2d 65 78 63 65 70 74 69 6f 6e 2d 68 61 6e 64 t-exception-hand
1ff0: 6c 65 72 29 29 29 0a 20 20 20 20 28 68 61 6e 64 ler))). (hand
2000: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
2010: 20 20 20 65 78 6e 0a 20 20 20 20 20 28 62 65 67 exn. (beg
2020: 69 6e 0a 20 20 20 20 20 20 20 28 64 65 62 75 67 in. (debug
2030: 3a 70 72 69 6e 74 20 30 20 22 46 61 69 6c 65 64 :print 0 "Failed
2040: 20 74 6f 20 62 69 6e 64 20 74 6f 20 70 6f 72 74 to bind to port
2050: 20 22 20 70 20 22 2c 20 74 72 79 69 6e 67 20 6e " p ", trying n
2060: 65 78 74 20 70 6f 72 74 22 29 0a 20 20 20 20 20 ext port").
2070: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2080: 20 22 20 20 20 45 58 43 45 50 54 49 4f 4e 3a 20 " EXCEPTION:
2090: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
20a0: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
20b0: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
20c0: 78 6e 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 28 xn)). ;; (
20d0: 6f 6c 64 2d 68 61 6e 64 6c 65 72 29 0a 20 20 20 old-handler).
20e0: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 2d 63 61 ;; (print-ca
20f0: 6c 6c 2d 63 68 61 69 6e 29 0a 20 20 20 20 20 20 ll-chain).
2100: 20 28 69 66 20 28 3e 20 74 72 79 6e 75 6d 20 30 (if (> trynum 0
2110: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 7a 6d ). (zm
2120: 71 2d 74 72 61 6e 73 70 6f 72 74 3a 66 69 6e 64 q-transport:find
2130: 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e 64 2d 6f -free-port-and-o
2140: 70 65 6e 20 69 66 61 63 65 20 73 20 28 2b 20 70 pen iface s (+ p
2150: 20 31 29 20 74 72 79 6e 75 6d 3a 20 28 2d 20 74 1) trynum: (- t
2160: 72 79 6e 75 6d 20 31 29 29 0a 20 20 20 20 20 20 rynum 1)).
2170: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2180: 74 2d 69 6e 66 6f 20 30 20 22 54 72 69 65 64 20 t-info 0 "Tried
2190: 70 6f 72 74 73 20 75 70 20 74 6f 20 22 20 70 20 ports up to " p
21a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
21b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 20 "
21c0: 62 75 74 20 61 6c 6c 20 77 65 72 65 20 69 6e 20 but all were in
21d0: 75 73 65 2e 20 50 6c 65 61 73 65 20 74 72 79 20 use. Please try
21e0: 61 20 64 69 66 66 65 72 65 6e 74 20 70 6f 72 74 a different port
21f0: 20 72 61 6e 67 65 20 62 79 20 73 74 61 72 74 69 range by starti
2200: 6e 67 20 74 68 65 20 73 65 72 76 65 72 20 77 69 ng the server wi
2210: 74 68 20 70 61 72 61 6d 65 74 65 72 20 5c 22 20 th parameter \"
2220: 2d 70 6f 72 74 20 4e 5c 22 20 77 68 65 72 65 20 -port N\" where
2230: 4e 20 69 73 20 74 68 65 20 73 74 61 72 74 69 6e N is the startin
2240: 67 20 70 6f 72 74 20 6e 75 6d 62 65 72 20 74 6f g port number to
2250: 20 75 73 65 22 29 29 0a 20 20 20 20 20 20 20 28 use")). (
2260: 65 78 69 74 29 29 20 3b 3b 20 54 6f 20 65 78 69 exit)) ;; To exi
2270: 74 20 6f 72 20 6e 6f 74 3f 20 54 68 61 74 20 69 t or not? That i
2280: 73 20 74 68 65 20 71 75 65 73 74 69 6f 6e 2e 0a s the question..
2290: 20 20 20 20 20 28 6c 65 74 20 28 28 7a 6d 71 2d (let ((zmq-
22a0: 75 72 6c 20 28 63 6f 6e 63 20 22 74 63 70 3a 2f url (conc "tcp:/
22b0: 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 29 29 /" iface ":" p))
22c0: 29 0a 20 20 20 20 20 20 20 28 64 65 62 75 67 3a ). (debug:
22d0: 70 72 69 6e 74 20 32 20 22 54 72 79 69 6e 67 20 print 2 "Trying
22e0: 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 20 to start server
22f0: 6f 6e 20 22 20 7a 6d 71 2d 75 72 6c 29 0a 20 20 on " zmq-url).
2300: 20 20 20 20 20 28 62 69 6e 64 2d 73 6f 63 6b 65 (bind-socke
2310: 74 20 73 20 7a 6d 71 2d 75 72 6c 29 0a 20 20 20 t s zmq-url).
2320: 20 20 20 20 28 6c 69 73 74 20 69 66 61 63 65 20 (list iface
2330: 73 20 70 6f 72 74 29 29 29 29 29 0a 0a 28 64 65 s port)))))..(de
2340: 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 6e 73 70 fine (zmq-transp
2350: 6f 72 74 3a 73 65 74 75 70 2d 70 6f 72 74 73 20 ort:setup-ports
2360: 69 70 61 64 64 72 73 74 72 20 73 74 61 72 74 70 ipaddrstr startp
2370: 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 ort). (let* ((s
2380: 31 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 1 (zmq-transport
2390: 3a 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d :find-free-port-
23a0: 61 6e 64 2d 6f 70 65 6e 20 69 70 61 64 64 72 73 and-open ipaddrs
23b0: 74 72 20 23 66 20 73 74 61 72 74 70 6f 72 74 20 tr #f startport
23c0: 27 70 75 6c 6c 29 29 0a 20 20 20 20 20 20 20 20 'pull)).
23d0: 20 28 70 31 20 28 63 61 64 64 72 20 73 31 29 29 (p1 (caddr s1))
23e0: 0a 20 20 20 20 20 20 20 20 20 28 73 32 20 28 7a . (s2 (z
23f0: 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 66 69 6e mq-transport:fin
2400: 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e 64 2d d-free-port-and-
2410: 6f 70 65 6e 20 69 70 61 64 64 72 73 74 72 20 23 open ipaddrstr #
2420: 66 20 28 2b 20 31 20 28 69 66 20 70 31 20 70 31 f (+ 1 (if p1 p1
2430: 20 28 2b 20 73 74 61 72 74 70 6f 72 74 20 31 29 (+ startport 1)
2440: 29 29 20 27 70 75 62 29 29 0a 20 20 20 20 20 20 )) 'pub)).
2450: 20 20 20 28 70 32 20 28 63 61 64 64 72 20 73 32 (p2 (caddr s2
2460: 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 72 ))). (set! *r
2470: 75 6e 72 65 6d 6f 74 65 2a 20 23 66 29 0a 20 20 unremote* #f).
2480: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2490: 20 22 53 65 72 76 65 72 20 73 74 61 72 74 65 64 "Server started
24a0: 20 6f 6e 20 22 20 69 70 61 64 64 72 73 74 72 20 on " ipaddrstr
24b0: 22 20 70 6f 72 74 73 20 22 20 70 31 20 22 20 61 " ports " p1 " a
24c0: 6e 64 20 22 20 70 32 29 0a 20 20 20 20 28 6d 75 nd " p2). (mu
24d0: 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 tex-lock! *heart
24e0: 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 beat-mutex*).
24f0: 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d 69 (set! *server-i
2500: 6e 66 6f 2a 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 nfo* (open-run-c
2510: 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 65 lose tasks:serve
2520: 72 2d 72 65 67 69 73 74 65 72 20 0a 09 09 09 09 r-register .....
2530: 09 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 0a .tasks:open-db .
2540: 09 09 09 09 09 28 63 75 72 72 65 6e 74 2d 70 72 .....(current-pr
2550: 6f 63 65 73 73 2d 69 64 29 20 0a 09 09 09 09 09 ocess-id) ......
2560: 69 70 61 64 64 72 73 74 72 20 70 31 20 0a 09 09 ipaddrstr p1 ...
2570: 09 09 09 30 20 0a 09 09 09 09 09 27 6c 69 76 65 ...0 ......'live
2580: 0a 09 09 09 09 09 27 7a 6d 71 0a 09 09 09 09 09 ......'zmq......
2590: 70 75 62 70 6f 72 74 3a 20 70 32 29 29 0a 20 20 pubport: p2)).
25a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
25b0: 6e 66 6f 20 31 31 20 22 2a 73 65 72 76 65 72 2d nfo 11 "*server-
25c0: 69 6e 66 6f 2a 20 73 65 74 20 74 6f 20 22 20 2a info* set to " *
25d0: 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 0a 20 20 server-info*).
25e0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
25f0: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
2600: 78 2a 29 0a 20 20 20 20 28 6c 69 73 74 20 73 31 x*). (list s1
2610: 20 73 32 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 s2)))..(define
2620: 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 6d (zmq-transport:m
2630: 6b 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 k-signature). (
2640: 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 message-digest-s
2650: 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 tring (md5-primi
2660: 74 69 76 65 29 20 0a 09 09 09 20 28 77 69 74 68 tive) .... (with
2670: 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e -output-to-strin
2680: 67 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 61 20 g.... (lambda
2690: 28 29 0a 09 09 09 20 20 20 20 20 28 77 72 69 74 ().... (writ
26a0: 65 20 28 6c 69 73 74 20 28 63 75 72 72 65 6e 74 e (list (current
26b0: 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 09 09 09 -directory).....
26c0: 09 20 20 28 61 72 67 76 29 29 29 29 29 29 29 0a . (argv))))))).
26d0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
26e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 =========.;; S E
2720: 20 52 20 56 20 45 20 52 20 20 20 55 20 54 20 49 R V E R U T I
2730: 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a 3b 3b L I T I E S .;;
2740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2780: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ======..;;======
2790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27d0: 0a 3b 3b 20 43 20 4c 20 49 20 45 20 4e 20 54 20 .;; C L I E N T
27e0: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
27f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 0a ==========..;; .
2830: 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 (define (zmq-tra
2840: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 6f nsport:client-so
2850: 63 6b 65 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 cket-connect ifa
2860: 63 65 20 70 6f 72 74 20 23 21 6b 65 79 20 28 63 ce port #!key (c
2870: 6f 6e 74 65 78 74 20 23 66 29 28 74 79 70 65 20 ontext #f)(type
2880: 27 72 65 71 29 28 73 75 62 73 63 72 69 70 74 69 'req)(subscripti
2890: 6f 6e 73 20 27 28 29 29 29 0a 20 20 28 64 65 62 ons '())). (deb
28a0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 ug:print-info 3
28b0: 22 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 "client-connect
28c0: 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 74 " iface ":" port
28d0: 20 22 2c 20 74 79 70 65 3d 22 20 74 79 70 65 20 ", type=" type
28e0: 22 2c 20 73 75 62 73 63 72 69 70 74 69 6f 6e 73 ", subscriptions
28f0: 3d 22 20 73 75 62 73 63 72 69 70 74 69 6f 6e 73 =" subscriptions
2900: 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 65 ). (let ((conne
2910: 63 74 2d 6f 6b 20 23 66 29 0a 09 28 7a 6d 71 2d ct-ok #f)..(zmq-
2920: 73 6f 63 6b 65 74 20 28 69 66 20 63 6f 6e 74 65 socket (if conte
2930: 78 74 20 0a 09 09 09 28 6d 61 6b 65 2d 73 6f 63 xt ....(make-soc
2940: 6b 65 74 20 74 79 70 65 20 63 6f 6e 74 65 78 74 ket type context
2950: 29 0a 09 09 09 28 6d 61 6b 65 2d 73 6f 63 6b 65 )....(make-socke
2960: 74 20 74 79 70 65 29 29 29 0a 09 28 63 6f 6e 75 t type)))..(conu
2970: 72 6c 20 20 20 20 20 28 7a 6d 71 2d 74 72 61 6e rl (zmq-tran
2980: 73 70 6f 72 74 3a 6d 61 6b 65 2d 73 65 72 76 65 sport:make-serve
2990: 72 2d 75 72 6c 20 28 6c 69 73 74 20 69 66 61 63 r-url (list ifac
29a0: 65 20 70 6f 72 74 29 29 29 29 0a 20 20 20 20 28 e port)))). (
29b0: 69 66 20 28 73 6f 63 6b 65 74 3f 20 7a 6d 71 2d if (socket? zmq-
29c0: 73 6f 63 6b 65 74 29 0a 20 20 20 20 20 28 62 65 socket). (be
29d0: 67 69 6e 0a 09 20 20 3b 3b 20 66 69 72 73 74 20 gin.. ;; first
29e0: 61 70 70 6c 79 20 73 75 62 73 63 72 69 70 74 69 apply subscripti
29f0: 6f 6e 73 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 ons.. (for-each
2a00: 20 28 6c 61 6d 62 64 61 20 28 73 75 62 73 63 72 (lambda (subscr
2a10: 69 70 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 iption)...
2a20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
2a30: 53 75 62 73 63 72 69 62 69 6e 67 20 74 6f 20 22 Subscribing to "
2a40: 20 73 75 62 73 63 72 69 70 74 69 6f 6e 29 0a 09 subscription)..
2a50: 09 20 20 20 20 20 20 28 73 6f 63 6b 65 74 2d 6f . (socket-o
2a60: 70 74 69 6f 6e 2d 73 65 74 21 20 7a 6d 71 2d 73 ption-set! zmq-s
2a70: 6f 63 6b 65 74 20 27 73 75 62 73 63 72 69 62 65 ocket 'subscribe
2a80: 20 73 75 62 73 63 72 69 70 74 69 6f 6e 29 29 0a subscription)).
2a90: 09 09 20 20 20 20 73 75 62 73 63 72 69 70 74 69 .. subscripti
2aa0: 6f 6e 73 29 0a 09 20 20 28 63 6f 6e 6e 65 63 74 ons).. (connect
2ab0: 2d 73 6f 63 6b 65 74 20 7a 6d 71 2d 73 6f 63 6b -socket zmq-sock
2ac0: 65 74 20 63 6f 6e 75 72 6c 29 0a 09 20 20 7a 6d et conurl).. zm
2ad0: 71 2d 73 6f 63 6b 65 74 29 0a 09 28 62 65 67 69 q-socket)..(begi
2ae0: 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e n.. (debug:prin
2af0: 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c t 0 "ERROR: Fail
2b00: 65 64 20 74 6f 20 6f 70 65 6e 20 73 6f 63 6b 65 ed to open socke
2b10: 74 20 74 6f 20 22 20 63 6f 6e 75 72 6c 29 0a 09 t to " conurl)..
2b20: 20 20 23 66 29 29 29 29 0a 0a 28 64 65 66 69 6e #f))))..(defin
2b30: 65 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 e (zmq-transport
2b40: 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 :client-connect
2b50: 69 66 61 63 65 20 70 75 6c 6c 70 6f 72 74 20 70 iface pullport p
2b60: 75 62 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 ubport). (let*
2b70: 28 28 70 75 73 68 2d 73 6f 63 6b 65 74 20 28 7a ((push-socket (z
2b80: 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 mq-transport:cli
2b90: 65 6e 74 2d 73 6f 63 6b 65 74 2d 63 6f 6e 6e 65 ent-socket-conne
2ba0: 63 74 20 69 66 61 63 65 20 70 75 6c 6c 70 6f 72 ct iface pullpor
2bb0: 74 20 74 79 70 65 3a 20 27 70 75 73 68 29 29 0a t type: 'push)).
2bc0: 09 20 28 73 75 62 2d 73 6f 63 6b 65 74 20 20 28 . (sub-socket (
2bd0: 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c zmq-transport:cl
2be0: 69 65 6e 74 2d 73 6f 63 6b 65 74 2d 63 6f 6e 6e ient-socket-conn
2bf0: 65 63 74 20 69 66 61 63 65 20 70 75 62 70 6f 72 ect iface pubpor
2c00: 74 0a 09 09 09 09 09 09 20 20 20 20 74 79 70 65 t....... type
2c10: 3a 20 27 73 75 62 0a 09 09 09 09 09 09 20 20 20 : 'sub.......
2c20: 20 73 75 62 73 63 72 69 70 74 69 6f 6e 73 3a 20 subscriptions:
2c30: 28 6c 69 73 74 20 28 63 6c 69 65 6e 74 3a 67 65 (list (client:ge
2c40: 74 2d 73 69 67 6e 61 74 75 72 65 29 20 22 61 6c t-signature) "al
2c50: 6c 22 29 29 29 0a 09 20 28 7a 6d 71 2d 73 6f 63 l"))).. (zmq-soc
2c60: 6b 65 74 73 20 28 76 65 63 74 6f 72 20 70 75 73 kets (vector pus
2c70: 68 2d 73 6f 63 6b 65 74 20 73 75 62 2d 73 6f 63 h-socket sub-soc
2c80: 6b 65 74 29 29 0a 09 20 28 6c 6f 67 69 6e 2d 72 ket)).. (login-r
2c90: 65 73 20 20 20 23 66 29 29 0a 20 20 20 20 28 64 es #f)). (d
2ca0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2cb0: 31 31 20 22 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 11 "zmq-transpor
2cc0: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
2cd0: 20 73 74 61 72 74 65 64 2e 20 4e 65 78 74 20 69 started. Next i
2ce0: 73 20 6c 6f 67 69 6e 22 29 0a 20 20 20 20 28 73 s login"). (s
2cf0: 65 74 21 20 6c 6f 67 69 6e 2d 72 65 73 20 28 63 et! login-res (c
2d00: 6c 69 65 6e 74 3a 6c 6f 67 69 6e 20 73 65 72 76 lient:login serv
2d10: 65 72 64 61 74 20 7a 6d 71 2d 73 6f 63 6b 65 74 erdat zmq-socket
2d20: 73 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 s)). (if (and
2d30: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6c 6f 67 (not (null? log
2d40: 69 6e 2d 72 65 73 29 29 0a 09 20 20 20 20 20 28 in-res)).. (
2d50: 63 61 72 20 6c 6f 67 69 6e 2d 72 65 73 29 29 0a car login-res)).
2d60: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
2d70: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
2d80: 4c 6f 67 67 65 64 20 69 6e 20 61 6e 64 20 63 6f Logged in and co
2d90: 6e 6e 65 63 74 65 64 20 74 6f 20 22 20 69 66 61 nnected to " ifa
2da0: 63 65 20 22 3a 22 20 70 75 6c 6c 70 6f 72 74 20 ce ":" pullport
2db0: 22 2f 22 20 70 75 62 70 6f 72 74 20 22 2e 22 29 "/" pubport ".")
2dc0: 0a 09 20 20 28 73 65 74 21 20 2a 72 75 6e 72 65 .. (set! *runre
2dd0: 6d 6f 74 65 2a 20 7a 6d 71 2d 73 6f 63 6b 65 74 mote* zmq-socket
2de0: 73 29 0a 09 20 20 7a 6d 71 2d 73 6f 63 6b 65 74 s).. zmq-socket
2df0: 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 s)..(begin.. (d
2e00: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2e10: 32 20 22 46 61 69 6c 65 64 20 74 6f 20 6c 6f 67 2 "Failed to log
2e20: 69 6e 20 6f 72 20 63 6f 6e 6e 65 63 74 20 74 6f in or connect to
2e30: 20 22 20 63 6f 6e 75 72 6c 29 0a 09 20 20 28 73 " conurl).. (s
2e40: 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 et! *runremote*
2e50: 23 66 29 0a 09 20 20 23 66 29 29 29 29 0a 0a 3b #f).. #f))))..;
2e60: 3b 20 72 75 6e 20 7a 6d 71 2d 74 72 61 6e 73 70 ; run zmq-transp
2e70: 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 ort:keep-running
2e80: 20 69 6e 20 61 20 70 61 72 61 6c 6c 65 6c 20 74 in a parallel t
2e90: 68 72 65 61 64 20 74 6f 20 6d 6f 6e 69 74 6f 72 hread to monitor
2ea0: 20 74 68 61 74 20 74 68 65 20 64 62 20 69 73 20 that the db is
2eb0: 62 65 69 6e 67 20 0a 3b 3b 20 75 73 65 64 20 61 being .;; used a
2ec0: 6e 64 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 61 nd to shutdown a
2ed0: 66 74 65 72 20 73 6f 6d 65 74 69 6d 65 20 69 66 fter sometime if
2ee0: 20 69 74 20 69 73 20 6e 6f 74 2e 0a 3b 3b 0a 28 it is not..;;.(
2ef0: 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 6e define (zmq-tran
2f00: 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 sport:keep-runni
2f10: 6e 67 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 ng). ;; if none
2f20: 20 72 75 6e 6e 69 6e 67 20 6f 72 20 69 66 20 3e running or if >
2f30: 20 32 30 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 20 seconds sinc
2f40: 65 20 0a 20 20 3b 3b 20 73 65 72 76 65 72 20 6c e . ;; server l
2f50: 61 73 74 20 75 73 65 64 20 74 68 65 6e 20 73 74 ast used then st
2f60: 61 72 74 20 73 68 75 74 64 6f 77 6e 0a 20 20 3b art shutdown. ;
2f70: 3b 20 54 68 69 73 20 74 68 72 65 61 64 20 77 61 ; This thread wa
2f80: 69 74 73 20 66 6f 72 20 74 68 65 20 73 65 72 76 its for the serv
2f90: 65 72 20 74 6f 20 63 6f 6d 65 20 61 6c 69 76 65 er to come alive
2fa0: 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 65 . (let* ((serve
2fb0: 72 2d 69 6e 66 6f 20 28 6c 65 74 20 6c 6f 6f 70 r-info (let loop
2fc0: 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ().
2fd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
2fe0: 20 28 28 73 64 61 74 20 23 66 29 29 0a 20 20 20 ((sdat #f)).
2ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3000: 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f (mutex-lo
3010: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
3020: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 utex*).
3030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3040: 20 28 73 65 74 21 20 73 64 61 74 20 2a 72 75 6e (set! sdat *run
3050: 72 65 6d 6f 74 65 2a 29 0a 20 20 20 20 20 20 20 remote*).
3060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3070: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
3080: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
3090: 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ex*).
30a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
30b0: 69 66 20 73 64 61 74 20 73 64 61 74 0a 20 20 20 if sdat sdat.
30c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30d0: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
30e0: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
30f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3100: 20 20 28 73 6c 65 65 70 20 34 29 0a 20 20 20 20 (sleep 4).
3110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3120: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
3130: 70 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 p)))))).
3140: 20 28 69 66 61 63 65 20 20 20 20 20 20 20 28 63 (iface (c
3150: 61 72 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 ar server-info))
3160: 0a 20 20 20 20 20 20 20 20 20 28 70 6f 72 74 20 . (port
3170: 20 20 20 20 20 20 20 28 63 61 64 72 20 73 65 72 (cadr ser
3180: 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 ver-info)).
3190: 20 20 20 20 28 6c 61 73 74 2d 61 63 63 65 73 73 (last-access
31a0: 20 30 29 0a 09 20 28 74 64 62 20 20 20 20 20 20 0).. (tdb
31b0: 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 (tasks:open-d
31c0: 62 29 29 0a 09 20 28 73 70 69 64 20 20 20 20 20 b)).. (spid
31d0: 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 (tasks:server
31e0: 2d 67 65 74 2d 73 65 72 76 65 72 2d 69 64 20 74 -get-server-id t
31f0: 64 62 20 23 66 20 69 66 61 63 65 20 70 6f 72 74 db #f iface port
3200: 20 23 66 29 29 29 0a 20 20 20 20 28 70 72 69 6e #f))). (prin
3210: 74 20 22 4b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 t "Keep-running
3220: 67 6f 74 20 73 65 72 76 65 72 20 70 69 64 20 22 got server pid "
3230: 20 73 70 69 64 20 22 2c 20 75 73 69 6e 67 20 69 spid ", using i
3240: 66 61 63 65 20 22 20 69 66 61 63 65 20 22 20 61 face " iface " a
3250: 6e 64 20 70 6f 72 74 20 22 20 70 6f 72 74 29 0a nd port " port).
3260: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
3270: 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 20 count 0)).
3280: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 34 (thread-sleep! 4
3290: 29 20 3b 3b 20 6e 6f 20 6e 65 65 64 20 74 6f 20 ) ;; no need to
32a0: 64 6f 20 74 68 69 73 20 76 65 72 79 20 6f 66 74 do this very oft
32b0: 65 6e 0a 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f en. ;; NB//
32c0: 20 73 79 6e 63 20 63 75 72 72 65 6e 74 6c 79 20 sync currently
32d0: 64 6f 65 73 20 4e 4f 54 20 72 65 74 75 72 6e 20 does NOT return
32e0: 71 75 65 75 65 2d 6c 65 6e 67 74 68 0a 20 20 20 queue-length.
32f0: 20 20 20 28 6c 65 74 20 28 29 20 3b 3b 20 28 71 (let () ;; (q
3300: 75 65 75 65 2d 6c 65 6e 20 28 63 64 62 3a 63 6c ueue-len (cdb:cl
3310: 69 65 6e 74 2d 63 61 6c 6c 20 73 65 72 76 65 72 ient-call server
3320: 2d 69 6e 66 6f 20 27 73 79 6e 63 20 23 74 20 31 -info 'sync #t 1
3330: 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 70 72 ))). ;; (pr
3340: 69 6e 74 20 22 53 65 72 76 65 72 20 72 75 6e 6e int "Server runn
3350: 69 6e 67 2c 20 63 6f 75 6e 74 20 69 73 20 22 20 ing, count is "
3360: 63 6f 75 6e 74 29 0a 20 20 20 20 20 20 20 20 28 count). (
3370: 69 66 20 28 3c 20 63 6f 75 6e 74 20 31 29 20 3b if (< count 1) ;
3380: 3b 20 33 78 33 20 3d 20 39 20 73 65 63 73 20 61 ; 3x3 = 9 secs a
3390: 70 72 6f 78 0a 20 20 20 20 20 20 20 20 20 20 20 prox.
33a0: 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 (loop (+ count
33b0: 31 29 29 29 0a 20 20 20 20 20 20 20 20 0a 20 20 1))). .
33c0: 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 47 ;; NOTE: G
33d0: 65 74 20 72 69 64 20 6f 66 20 74 68 69 73 20 6d et rid of this m
33e0: 65 63 68 61 6e 69 73 6d 21 20 49 74 20 72 65 61 echanism! It rea
33f0: 6c 6c 79 20 69 73 20 6e 6f 74 20 6e 65 65 64 65 lly is not neede
3400: 64 2e 2e 2e 0a 20 20 20 20 20 20 20 20 28 74 61 d.... (ta
3410: 73 6b 73 3a 73 65 72 76 65 72 2d 75 70 64 61 74 sks:server-updat
3420: 65 2d 68 65 61 72 74 62 65 61 74 20 74 64 62 20 e-heartbeat tdb
3430: 73 70 69 64 29 0a 20 20 20 20 20 20 0a 20 20 20 spid). .
3440: 20 20 20 20 20 3b 3b 20 28 69 66 20 3b 3b 20 28 ;; (if ;; (
3450: 6f 72 20 28 3e 20 6e 75 6d 72 75 6e 6e 69 6e 67 or (> numrunning
3460: 20 30 29 20 3b 3b 20 73 74 61 79 20 61 6c 69 76 0) ;; stay aliv
3470: 65 20 66 6f 72 20 74 77 6f 20 64 61 79 73 20 61 e for two days a
3480: 66 74 65 72 20 6c 61 73 74 20 61 63 63 65 73 73 fter last access
3490: 0a 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d . (mutex-
34a0: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat
34b0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 -mutex*).
34c0: 20 28 73 65 74 21 20 6c 61 73 74 2d 61 63 63 65 (set! last-acce
34d0: 73 73 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 ss *last-db-acce
34e0: 73 73 2a 29 0a 20 20 20 20 20 20 20 20 28 6d 75 ss*). (mu
34f0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 tex-unlock! *hea
3500: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 rtbeat-mutex*).
3510: 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 2b (if (> (+
3520: 20 6c 61 73 74 2d 61 63 63 65 73 73 0a 20 20 20 last-access.
3530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
3540: 3b 20 28 2a 20 35 30 20 36 30 20 36 30 29 20 20 ; (* 50 60 60)
3550: 20 20 3b 3b 20 34 38 20 68 72 73 0a 20 20 20 20 ;; 48 hrs.
3560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
3570: 20 36 30 20 20 20 20 20 20 20 20 20 20 20 20 20 60
3580: 20 3b 3b 20 6f 6e 65 20 6d 69 6e 75 74 65 0a 20 ;; one minute.
3590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
35a0: 20 3b 3b 20 28 2a 20 36 30 20 36 30 29 20 20 20 ;; (* 60 60)
35b0: 20 20 20 20 3b 3b 20 6f 6e 65 20 68 6f 75 72 0a ;; one hour.
35c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
35d0: 20 20 28 2a 20 34 35 20 36 30 29 20 20 20 20 20 (* 45 60)
35e0: 20 20 20 20 20 3b 3b 20 34 35 20 6d 69 6e 75 74 ;; 45 minut
35f0: 65 73 2c 20 75 6e 74 69 6c 20 74 68 65 20 64 62 es, until the db
3600: 20 64 65 6c 65 74 69 6f 6e 20 62 75 67 20 69 73 deletion bug is
3610: 20 66 69 78 65 64 2e 0a 20 20 20 20 20 20 20 20 fixed..
3620: 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 ).
3630: 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 (curr
3640: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 ent-seconds)).
3650: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
3660: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3670: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
3680: 20 32 20 22 53 65 72 76 65 72 20 63 6f 6e 74 69 2 "Server conti
3690: 6e 75 69 6e 67 2c 20 73 65 63 6f 6e 64 73 20 73 nuing, seconds s
36a0: 69 6e 63 65 20 6c 61 73 74 20 64 62 20 61 63 63 ince last db acc
36b0: 65 73 73 3a 20 22 20 28 2d 20 28 63 75 72 72 65 ess: " (- (curre
36c0: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 74 nt-seconds) last
36d0: 2d 61 63 63 65 73 73 29 29 0a 20 20 20 20 20 20 -access)).
36e0: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 30 29 (loop 0)
36f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 62 ). (b
3700: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
3710: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3720: 69 6e 66 6f 20 30 20 22 53 74 61 72 74 69 6e 67 info 0 "Starting
3730: 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 74 68 65 to shutdown the
3740: 20 73 65 72 76 65 72 2e 22 29 0a 20 20 20 20 20 server.").
3750: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 65 65 64 ;; need
3760: 20 74 6f 20 64 65 6c 65 74 65 20 6f 6e 6c 79 20 to delete only
3770: 2a 6d 79 2a 20 73 65 72 76 65 72 20 65 6e 74 72 *my* server entr
3780: 79 20 28 66 75 74 75 72 65 20 75 73 65 29 0a 20 y (future use).
3790: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
37a0: 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 t! *time-to-exit
37b0: 2a 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 * #t).
37c0: 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 (tasks:serve
37d0: 72 2d 64 65 72 65 67 69 73 74 65 72 2d 73 65 6c r-deregister-sel
37e0: 66 20 74 64 62 20 28 67 65 74 2d 68 6f 73 74 2d f tdb (get-host-
37f0: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 name)).
3800: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
3810: 65 70 21 20 31 29 0a 20 20 20 20 20 20 20 20 20 ep! 1).
3820: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3830: 74 2d 69 6e 66 6f 20 30 20 22 4d 61 78 20 63 61 t-info 0 "Max ca
3840: 63 68 65 64 20 71 75 65 72 69 65 73 20 77 61 73 ched queries was
3850: 20 22 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 " *max-cache-si
3860: 7a 65 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ze*).
3870: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3880: 69 6e 66 6f 20 30 20 22 53 65 72 76 65 72 20 73 info 0 "Server s
3890: 68 75 74 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 65 hutdown complete
38a0: 2e 20 45 78 69 74 69 6e 67 22 29 0a 20 20 20 20 . Exiting").
38b0: 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 29 (exit)
38c0: 29 29 29 29 29 29 0a 0a 3b 3b 20 61 6c 6c 20 72 ))))))..;; all r
38d0: 6f 75 74 65 73 20 74 68 6f 75 67 68 20 68 65 72 outes though her
38e0: 65 20 65 6e 64 20 69 6e 20 65 78 69 74 20 2e 2e e end in exit ..
38f0: 2e 0a 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 ..(define (zmq-t
3900: 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 29 ransport:launch)
3910: 0a 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 6f 70 . (if (not *top
3920: 70 61 74 68 2a 29 0a 20 20 20 20 20 20 28 69 66 path*). (if
3930: 20 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 (not (setup-for
3940: 2d 72 75 6e 29 29 0a 09 20 20 28 62 65 67 69 6e -run)).. (begin
3950: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
3960: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 63 61 6e nt 0 "ERROR: can
3970: 6e 6f 74 20 66 69 6e 64 20 6d 65 67 61 74 65 73 not find megates
3980: 74 2e 63 6f 6e 66 69 67 2c 20 65 78 69 74 69 6e t.config, exitin
3990: 67 22 29 0a 09 20 20 20 20 28 65 78 69 74 29 29 g").. (exit))
39a0: 29 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e )). (debug:prin
39b0: 74 2d 69 6e 66 6f 20 32 20 22 53 74 61 72 74 69 t-info 2 "Starti
39c0: 6e 67 20 7a 6d 71 20 73 65 72 76 65 72 22 29 0a ng zmq server").
39d0: 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a 20 (if *toppath*
39e0: 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 3b 3b . (let* (;;
39f0: 20 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 (th1 (make-thre
3a00: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 ad (lambda ()..
3a10: 20 20 20 20 3b 3b 20 20 20 20 20 20 09 20 20 20 ;; .
3a20: 20 20 20 20 28 6c 65 74 20 28 28 73 65 72 76 65 (let ((serve
3a30: 72 2d 69 6e 66 6f 20 23 66 29 29 0a 09 20 20 20 r-info #f))..
3a40: 20 20 3b 3b 20 20 20 20 20 20 09 09 20 3b 3b 20 ;; .. ;;
3a50: 77 61 69 74 20 66 6f 72 20 74 68 65 20 73 65 72 wait for the ser
3a60: 76 65 72 20 74 6f 20 62 65 20 6f 6e 6c 69 6e 65 ver to be online
3a70: 20 61 6e 64 20 61 76 61 69 6c 61 62 6c 65 0a 09 and available..
3a80: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 09 09 20 ;; ..
3a90: 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 09 20 20 (let loop ()..
3aa0: 20 20 20 3b 3b 09 09 09 20 20 20 28 64 65 62 75 ;;... (debu
3ab0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
3ac0: 57 61 69 74 69 6e 67 20 66 6f 72 20 74 68 65 20 Waiting for the
3ad0: 73 65 72 76 65 72 20 74 6f 20 63 6f 6d 65 20 6f server to come o
3ae0: 6e 6c 69 6e 65 20 62 65 66 6f 72 65 20 73 74 61 nline before sta
3af0: 72 74 69 6e 67 20 68 65 61 72 74 62 65 61 74 22 rting heartbeat"
3b00: 29 0a 09 20 20 20 20 20 3b 3b 20 20 20 20 20 20 ).. ;;
3b10: 09 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 .. (thread-sle
3b20: 65 70 21 20 32 29 0a 09 20 20 20 20 20 3b 3b 20 ep! 2).. ;;
3b30: 20 20 20 20 20 09 09 20 20 20 28 6d 75 74 65 78 .. (mutex
3b40: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea
3b50: 74 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 20 t-mutex*)..
3b60: 3b 3b 20 20 20 20 20 20 09 09 20 20 20 28 73 65 ;; .. (se
3b70: 74 21 20 73 65 72 76 65 72 2d 69 6e 66 6f 20 2a t! server-info *
3b80: 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 29 0a 09 server-info* )..
3b90: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 09 09 20 ;; ..
3ba0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
3bb0: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
3bc0: 78 2a 29 0a 09 20 20 20 20 20 3b 3b 20 20 20 20 x*).. ;;
3bd0: 20 20 09 09 20 20 20 28 69 66 20 28 6e 6f 74 20 .. (if (not
3be0: 73 65 72 76 65 72 2d 69 6e 66 6f 29 28 6c 6f 6f server-info)(loo
3bf0: 70 29 29 29 0a 09 20 20 20 20 20 3b 3b 09 09 09 p))).. ;;...
3c00: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
3c10: 22 53 65 72 76 65 72 20 61 6c 69 76 65 2c 20 73 "Server alive, s
3c20: 74 61 72 74 69 6e 67 20 73 65 6c 66 2d 70 69 6e tarting self-pin
3c30: 67 22 29 0a 09 20 20 20 20 20 3b 3b 20 20 20 20 g").. ;;
3c40: 20 20 09 09 20 28 7a 6d 71 2d 74 72 61 6e 73 70 .. (zmq-transp
3c50: 6f 72 74 3a 73 65 6c 66 2d 70 69 6e 67 20 73 65 ort:self-ping se
3c60: 72 76 65 72 2d 69 6e 66 6f 29 0a 09 20 20 20 20 rver-info)..
3c70: 20 3b 3b 20 20 20 20 20 20 09 09 20 29 29 0a 09 ;; .. ))..
3c80: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 09 20 20 ;; .
3c90: 20 20 20 22 53 65 6c 66 20 70 69 6e 67 22 29 29 "Self ping"))
3ca0: 0a 09 20 20 20 20 20 28 74 68 32 20 28 6d 61 6b .. (th2 (mak
3cb0: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
3cc0: 20 28 29 0a 09 09 09 09 20 28 7a 6d 71 2d 74 72 ()..... (zmq-tr
3cd0: 61 6e 73 70 6f 72 74 3a 72 75 6e 20 0a 09 09 09 ansport:run ....
3ce0: 09 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 . (if (args:get
3cf0: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a -arg "-server").
3d00: 09 09 09 09 20 20 20 20 20 20 28 61 72 67 73 3a .... (args:
3d10: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
3d20: 22 29 0a 09 09 09 09 20 20 20 20 20 20 22 2d 22 ")..... "-"
3d30: 29 29 29 20 22 53 65 72 76 65 72 20 72 75 6e 22 ))) "Server run"
3d40: 29 29 0a 09 20 20 20 20 20 3b 3b 20 28 74 68 33 )).. ;; (th3
3d50: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c (make-thread (l
3d60: 61 6d 62 64 61 20 28 29 28 7a 6d 71 2d 74 72 61 ambda ()(zmq-tra
3d70: 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e nsport:keep-runn
3d80: 69 6e 67 29 29 20 22 4b 65 65 70 20 72 75 6e 6e ing)) "Keep runn
3d90: 69 6e 67 22 29 29 0a 09 20 20 20 20 20 29 0a 09 ing")).. )..
3da0: 28 73 65 74 21 20 2a 63 6c 69 65 6e 74 2d 6e 6f (set! *client-no
3db0: 6e 2d 62 6c 6f 63 6b 69 6e 67 2d 6d 6f 64 65 2a n-blocking-mode*
3dc0: 20 23 74 29 0a 09 3b 3b 20 28 74 68 72 65 61 64 #t)..;; (thread
3dd0: 2d 73 74 61 72 74 21 20 74 68 31 29 0a 09 28 74 -start! th1)..(t
3de0: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 hread-start! th2
3df0: 29 0a 09 3b 3b 20 28 74 68 72 65 61 64 2d 73 74 )..;; (thread-st
3e00: 61 72 74 21 20 74 68 33 29 0a 09 28 73 65 74 21 art! th3)..(set!
3e10: 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 *didsomething*
3e20: 23 74 29 0a 09 3b 3b 20 28 74 68 72 65 61 64 2d #t)..;; (thread-
3e30: 6a 6f 69 6e 21 20 74 68 33 29 0a 09 28 74 68 72 join! th3)..(thr
3e40: 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 0a 09 ead-join! th2)..
3e50: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
3e60: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 rint 0 "ERROR: F
3e70: 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 20 66 ailed to setup f
3e80: 6f 72 20 6d 65 67 61 74 65 73 74 22 29 29 29 0a or megatest"))).
3e90: 0a 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 .(define (zmq-tr
3ea0: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 ansport:client-s
3eb0: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 ignal-handler si
3ec0: 67 6e 75 6d 29 0a 20 20 28 68 61 6e 64 6c 65 2d gnum). (handle-
3ed0: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 exceptions. ex
3ee0: 6e 0a 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e n. (debug:prin
3ef0: 74 20 22 20 2e 2e 2e 20 65 78 69 74 69 6e 67 20 t " ... exiting
3f00: 2e 2e 2e 22 29 0a 20 20 20 28 6c 65 74 20 28 28 ..."). (let ((
3f10: 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th1 (make-thread
3f20: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
3f30: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 2a 72 65 (if (not *re
3f40: 63 65 69 76 65 64 2d 72 65 73 70 6f 6e 73 65 2a ceived-response*
3f50: 29 0a 09 09 09 09 20 28 72 65 63 65 69 76 65 2d )..... (receive-
3f60: 6d 65 73 73 61 67 65 2a 20 2a 72 75 6e 72 65 6d message* *runrem
3f70: 6f 74 65 2a 29 29 29 20 3b 3b 20 66 6c 75 73 68 ote*))) ;; flush
3f80: 20 6f 75 74 20 6c 61 73 74 20 63 61 6c 6c 20 69 out last call i
3f90: 66 20 61 70 70 6c 69 63 61 62 6c 65 0a 09 09 09 f applicable....
3fa0: 20 20 20 22 65 61 74 20 72 65 73 70 6f 6e 73 65 "eat response
3fb0: 22 29 29 0a 09 20 28 74 68 32 20 28 6d 61 6b 65 ")).. (th2 (make
3fc0: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
3fd0: 28 29 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 ().... (debu
3fe0: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
3ff0: 3a 20 52 65 63 65 69 76 65 64 20 5e 43 2c 20 61 : Received ^C, a
4000: 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 ttempting clean
4010: 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 exit. Please be
4020: 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 patient and wait
4030: 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 20 62 a few seconds b
4040: 65 66 6f 72 65 20 68 69 74 74 69 6e 67 20 5e 43 efore hitting ^C
4050: 20 61 67 61 69 6e 2e 22 29 0a 09 09 09 20 20 20 again.")....
4060: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
4070: 20 33 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 3) ;; give the
4080: 66 6c 75 73 68 20 74 68 72 65 65 20 73 65 63 6f flush three seco
4090: 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 73 20 73 nds to do it's s
40a0: 74 75 66 66 0a 09 09 09 20 20 20 20 20 28 64 65 tuff.... (de
40b0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 20 20 20 bug:print 0 "
40c0: 20 20 20 20 44 6f 6e 65 2e 22 29 0a 09 09 09 20 Done.")....
40d0: 20 20 20 20 28 65 78 69 74 20 34 29 29 0a 09 09 (exit 4))...
40e0: 09 20 20 20 22 65 78 69 74 20 6f 6e 20 5e 43 20 . "exit on ^C
40f0: 74 69 6d 65 72 22 29 29 29 0a 20 20 20 20 20 28 timer"))). (
4100: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
4110: 32 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 2d 2). (thread-
4120: 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 start! th1).
4130: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
4140: 68 32 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 h2))))..(define
4150: 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 (zmq-transport:c
4160: 6c 69 65 6e 74 2d 6c 61 75 6e 63 68 29 0a 20 20 lient-launch).
4170: 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 (set-signal-hand
4180: 6c 65 72 21 20 73 69 67 6e 61 6c 2f 69 6e 74 20 ler! signal/int
4190: 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c zmq-transport:cl
41a0: 69 65 6e 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 ient-signal-hand
41b0: 6c 65 72 29 0a 20 20 20 28 69 66 20 28 7a 6d 71 ler). (if (zmq
41c0: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e -transport:clien
41d0: 74 2d 73 65 74 75 70 29 0a 20 20 20 20 20 20 20 t-setup).
41e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
41f0: 6f 20 32 20 22 63 6f 6e 6e 65 63 74 65 64 20 61 o 2 "connected a
4200: 73 20 63 6c 69 65 6e 74 22 29 0a 20 20 20 20 20 s client").
4210: 20 20 28 62 65 67 69 6e 0a 09 20 28 64 65 62 75 (begin.. (debu
4220: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
4230: 3a 20 46 61 69 6c 65 64 20 74 6f 20 63 6f 6e 6e : Failed to conn
4240: 65 63 74 20 61 73 20 63 6c 69 65 6e 74 22 29 0a ect as client").
4250: 09 20 28 65 78 69 74 29 29 29 29 0a 0a 3b 3b 3d . (exit))))..;;=
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 3d 3d 3d ================
4280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42a0: 3d 3d 3d 3d 3d 0a 3b 3b 20 44 65 66 75 6e 63 74 =====.;; Defunct
42b0: 20 66 75 6e 63 74 69 6f 6e 73 0a 3b 3b 3d 3d 3d functions.;;===
42c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4300: 3d 3d 3d 0a 0a 3b 3b 20 70 69 6e 67 20 61 20 73 ===..;; ping a s
4310: 65 72 76 65 72 20 61 6e 64 20 72 65 74 75 72 6e erver and return
4320: 20 6e 75 6d 62 65 72 20 6f 66 20 63 6c 69 65 6e number of clien
4330: 74 73 20 6f 72 20 23 66 20 28 69 66 20 6e 6f 20 ts or #f (if no
4340: 72 65 73 70 6f 6e 73 65 29 0a 3b 3b 20 4e 4f 54 response).;; NOT
4350: 20 49 4e 20 55 53 45 21 0a 28 64 65 66 69 6e 65 IN USE!.(define
4360: 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a (zmq-transport:
4370: 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 23 ping host port #
4380: 21 6b 65 79 20 28 73 65 63 73 20 31 30 29 28 72 !key (secs 10)(r
4390: 65 74 75 72 6e 2d 73 6f 63 6b 65 74 20 23 66 29 eturn-socket #f)
43a0: 29 0a 20 20 28 63 64 62 3a 75 73 65 2d 6e 6f 6e ). (cdb:use-non
43b0: 2d 62 6c 6f 63 6b 69 6e 67 2d 6d 6f 64 65 0a 20 -blocking-mode.
43c0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
43d0: 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 23 66 (let* ((res #f
43e0: 29 0a 09 20 20 20 20 28 74 68 31 20 28 6d 61 6b ).. (th1 (mak
43f0: 65 2d 74 68 72 65 61 64 0a 09 09 20 20 28 6c 61 e-thread... (la
4400: 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 28 6c mbda ()... (l
4410: 65 74 2a 20 28 28 7a 6d 71 2d 63 6f 6e 74 65 78 et* ((zmq-contex
4420: 74 20 28 6d 61 6b 65 2d 63 6f 6e 74 65 78 74 20 t (make-context
4430: 31 29 29 0a 09 09 09 20 20 20 28 7a 6d 71 2d 73 1)).... (zmq-s
4440: 6f 63 6b 65 74 20 20 28 7a 6d 71 2d 74 72 61 6e ocket (zmq-tran
4450: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e sport:client-con
4460: 6e 65 63 74 20 68 6f 73 74 20 70 6f 72 74 20 63 nect host port c
4470: 6f 6e 74 65 78 74 3a 20 7a 6d 71 2d 63 6f 6e 74 ontext: zmq-cont
4480: 65 78 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 ext)))... (
4490: 69 66 20 7a 6d 71 2d 73 6f 63 6b 65 74 0a 09 09 if zmq-socket...
44a0: 09 20 20 28 69 66 20 28 7a 6d 71 2d 74 72 61 6e . (if (zmq-tran
44b0: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 6c 6f 67 sport:client-log
44c0: 69 6e 20 7a 6d 71 2d 73 6f 63 6b 65 74 29 0a 09 in zmq-socket)..
44d0: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e .. (let ((n
44e0: 75 6d 63 6c 69 65 6e 74 73 20 28 63 64 62 3a 6e umclients (cdb:n
44f0: 75 6d 2d 63 6c 69 65 6e 74 73 20 7a 6d 71 2d 73 um-clients zmq-s
4500: 6f 63 6b 65 74 29 29 29 0a 09 09 09 09 28 69 66 ocket))).....(if
4510: 20 28 6e 6f 74 20 72 65 74 75 72 6e 2d 73 6f 63 (not return-soc
4520: 6b 65 74 29 0a 09 09 09 09 20 20 20 20 28 62 65 ket)..... (be
4530: 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 28 7a gin..... (z
4540: 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 mq-transport:cli
4550: 65 6e 74 2d 6c 6f 67 6f 75 74 20 7a 6d 71 2d 73 ent-logout zmq-s
4560: 6f 63 6b 65 74 29 0a 09 09 09 09 20 20 20 20 20 ocket).....
4570: 20 28 63 6c 6f 73 65 2d 73 6f 63 6b 65 74 20 20 (close-socket
4580: 7a 6d 71 2d 73 6f 63 6b 65 74 29 29 29 0a 09 09 zmq-socket)))...
4590: 09 09 28 73 65 74 21 20 72 65 73 20 28 6c 69 73 ..(set! res (lis
45a0: 74 20 23 74 20 6e 75 6d 63 6c 69 65 6e 74 73 20 t #t numclients
45b0: 28 69 66 20 72 65 74 75 72 6e 2d 73 6f 63 6b 65 (if return-socke
45c0: 74 20 7a 6d 71 2d 73 6f 63 6b 65 74 20 23 66 29 t zmq-socket #f)
45d0: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 ))).... (be
45e0: 67 69 6e 0a 09 09 09 09 3b 3b 20 28 63 6c 6f 73 gin.....;; (clos
45f0: 65 2d 73 6f 63 6b 65 74 20 7a 6d 71 2d 73 6f 63 e-socket zmq-soc
4600: 6b 65 74 29 0a 09 09 09 09 28 73 65 74 21 20 72 ket).....(set! r
4610: 65 73 20 28 6c 69 73 74 20 23 66 20 22 43 41 4e es (list #f "CAN
4620: 27 54 20 4c 4f 47 49 4e 22 20 23 66 29 29 29 29 'T LOGIN" #f))))
4630: 0a 09 09 09 20 20 28 73 65 74 21 20 72 65 73 20 .... (set! res
4640: 28 6c 69 73 74 20 23 66 20 22 43 41 4e 27 54 20 (list #f "CAN'T
4650: 43 4f 4e 4e 45 43 54 22 20 23 66 29 29 29 29 29 CONNECT" #f)))))
4660: 0a 09 09 20 20 22 50 69 6e 67 3a 20 74 68 31 22 ... "Ping: th1"
4670: 29 29 0a 09 20 20 20 20 28 74 68 32 20 28 6d 61 )).. (th2 (ma
4680: 6b 65 2d 74 68 72 65 61 64 0a 09 09 20 20 28 6c ke-thread... (l
4690: 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 28 ambda ()... (
46a0: 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 let loop ((count
46b0: 20 31 29 29 0a 09 09 20 20 20 20 20 20 28 64 65 1))... (de
46c0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
46d0: 20 22 50 69 6e 67 20 22 20 63 6f 75 6e 74 20 22 "Ping " count "
46e0: 20 73 65 72 76 65 72 20 6f 6e 20 22 20 68 6f 73 server on " hos
46f0: 74 20 22 20 61 74 20 70 6f 72 74 20 22 20 70 6f t " at port " po
4700: 72 74 29 0a 09 09 20 20 20 20 20 20 28 74 68 72 rt)... (thr
4710: 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 09 ead-sleep! 2)...
4720: 20 20 20 20 20 20 28 69 66 20 28 3c 20 63 6f 75 (if (< cou
4730: 6e 74 20 28 2f 20 73 65 63 73 20 32 29 29 0a 09 nt (/ secs 2))..
4740: 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 .. (loop (+ cou
4750: 6e 74 20 31 29 29 29 29 0a 09 09 20 20 20 20 3b nt 1))))... ;
4760: 3b 20 28 74 68 72 65 61 64 2d 74 65 72 6d 69 6e ; (thread-termin
4770: 61 74 65 21 20 74 68 31 29 0a 09 09 20 20 20 20 ate! th1)...
4780: 28 73 65 74 21 20 72 65 73 20 28 6c 69 73 74 20 (set! res (list
4790: 23 66 20 22 54 49 4d 45 44 20 4f 55 54 22 20 23 #f "TIMED OUT" #
47a0: 66 29 29 29 0a 09 09 20 20 22 50 69 6e 67 3a 20 f)))... "Ping:
47b0: 74 68 32 22 29 29 29 0a 20 20 20 20 20 20 20 28 th2"))). (
47c0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
47d0: 32 29 0a 20 20 20 20 20 20 20 28 74 68 72 65 61 2). (threa
47e0: 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 d-start! th1).
47f0: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
4800: 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a 09 28 73 eptions..exn..(s
4810: 65 74 21 20 72 65 73 20 28 6c 69 73 74 20 23 66 et! res (list #f
4820: 20 22 54 49 4d 45 44 20 4f 55 54 22 20 23 66 29 "TIMED OUT" #f)
4830: 29 0a 09 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 )..(thread-join!
4840: 20 74 68 31 20 73 65 63 73 29 29 0a 20 20 20 20 th1 secs)).
4850: 20 20 20 72 65 73 29 29 29 29 0a 0a 3b 3b 20 28 res))))..;; (
4860: 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 6e define (zmq-tran
4870: 73 70 6f 72 74 3a 73 65 6c 66 2d 70 69 6e 67 20 sport:self-ping
4880: 73 65 72 76 65 72 2d 69 6e 66 6f 29 0a 3b 3b 20 server-info).;;
4890: 20 20 3b 3b 20 73 65 72 76 65 72 2d 69 6e 66 6f ;; server-info
48a0: 3a 20 73 65 72 76 65 72 2d 69 64 20 69 6e 74 65 : server-id inte
48b0: 72 66 61 63 65 20 70 75 6c 6c 70 6f 72 74 20 70 rface pullport p
48c0: 75 62 70 6f 72 74 0a 3b 3b 20 20 20 28 6c 65 74 ubport.;; (let
48d0: 20 28 28 69 66 61 63 65 20 20 20 20 28 6c 69 73 ((iface (lis
48e0: 74 2d 72 65 66 20 73 65 72 76 65 72 2d 69 6e 66 t-ref server-inf
48f0: 6f 20 31 29 29 0a 3b 3b 20 09 28 70 75 6c 6c 70 o 1)).;; .(pullp
4900: 6f 72 74 20 28 6c 69 73 74 2d 72 65 66 20 73 65 ort (list-ref se
4910: 72 76 65 72 2d 69 6e 66 6f 20 32 29 29 0a 3b 3b rver-info 2)).;;
4920: 20 09 28 70 75 62 70 6f 72 74 20 20 28 6c 69 73 .(pubport (lis
4930: 74 2d 72 65 66 20 73 65 72 76 65 72 2d 69 6e 66 t-ref server-inf
4940: 6f 20 33 29 29 29 0a 3b 3b 20 20 20 20 20 28 7a o 3))).;; (z
4950: 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 mq-transport:cli
4960: 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 63 ent-connect ifac
4970: 65 20 70 75 6c 6c 70 6f 72 74 20 70 75 62 70 6f e pullport pubpo
4980: 72 74 29 0a 3b 3b 20 20 20 20 20 28 6c 65 74 20 rt).;; (let
4990: 6c 6f 6f 70 20 28 29 0a 3b 3b 20 20 20 20 20 20 loop ().;;
49a0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
49b0: 32 29 0a 3b 3b 20 20 20 20 20 20 20 28 63 64 62 2).;; (cdb
49c0: 3a 63 6c 69 65 6e 74 2d 63 61 6c 6c 20 2a 72 75 :client-call *ru
49d0: 6e 72 65 6d 6f 74 65 2a 20 27 70 69 6e 67 20 23 nremote* 'ping #
49e0: 74 29 0a 3b 3b 20 20 20 20 20 20 20 28 64 65 62 t).;; (deb
49f0: 75 67 3a 70 72 69 6e 74 20 34 20 22 7a 6d 71 2d ug:print 4 "zmq-
4a00: 74 72 61 6e 73 70 6f 72 74 3a 73 65 6c 66 2d 70 transport:self-p
4a10: 69 6e 67 20 2d 20 49 27 6d 20 61 6c 69 76 65 20 ing - I'm alive
4a20: 6f 6e 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 on " iface ":" p
4a30: 75 6c 6c 70 6f 72 74 20 22 2f 22 20 70 75 62 70 ullport "/" pubp
4a40: 6f 72 74 20 22 21 22 29 0a 3b 3b 20 20 20 20 20 ort "!").;;
4a50: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
4a60: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
4a70: 29 0a 3b 3b 20 20 20 20 20 20 20 28 73 65 74 21 ).;; (set!
4a80: 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 *server-loop-he
4a90: 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 72 65 art-beat* (curre
4aa0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 3b 3b 20 nt-seconds)).;;
4ab0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
4ac0: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
4ad0: 6d 75 74 65 78 2a 29 0a 3b 3b 20 20 20 20 20 20 mutex*).;;
4ae0: 20 28 6c 6f 6f 70 29 29 29 29 0a 20 20 20 20 0a (loop)))). .
4af0: 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 (define (zmq-tra
4b00: 6e 73 70 6f 72 74 3a 72 65 70 6c 79 20 70 75 62 nsport:reply pub
4b10: 73 6f 63 6b 20 74 61 72 67 65 74 20 71 75 65 72 sock target quer
4b20: 79 2d 73 69 67 20 73 75 63 63 65 73 73 2f 66 61 y-sig success/fa
4b30: 69 6c 20 72 65 73 75 6c 74 29 0a 20 20 28 64 65 il result). (de
4b40: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
4b50: 31 20 22 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 1 "zmq-transport
4b60: 3a 72 65 70 6c 79 20 74 61 72 67 65 74 3d 22 20 :reply target="
4b70: 74 61 72 67 65 74 20 22 2c 20 72 65 73 75 6c 74 target ", result
4b80: 3d 22 20 72 65 73 75 6c 74 29 0a 20 20 28 73 65 =" result). (se
4b90: 6e 64 2d 6d 65 73 73 61 67 65 20 70 75 62 73 6f nd-message pubso
4ba0: 63 6b 20 74 61 72 67 65 74 20 73 65 6e 64 2d 6d ck target send-m
4bb0: 6f 72 65 3a 20 23 74 29 0a 20 20 28 73 65 6e 64 ore: #t). (send
4bc0: 2d 6d 65 73 73 61 67 65 20 70 75 62 73 6f 63 6b -message pubsock
4bd0: 20 28 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 (db:obj->string
4be0: 20 28 76 65 63 74 6f 72 20 73 75 63 63 65 73 73 (vector success
4bf0: 2f 66 61 69 6c 20 71 75 65 72 79 2d 73 69 67 20 /fail query-sig
4c00: 72 65 73 75 6c 74 29 29 29 29 0a 0a result))))..