Artifact 82efec97d4b85f9de63b6de49bc5a937349bfe0e:
- File zmq-transport.scm — part of check-in [643c26a524] at 2013-03-10 18:41:26 on branch dev — Completed move of functions to client.scm (user: matt size: 19469) [more...]
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 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 *server-loop-h 0800: 65 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 72 eart-beat* (curr 0810: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 28 64 ent-seconds)).(d 0820: 65 66 69 6e 65 20 2a 68 65 61 72 74 62 65 61 74 efine *heartbeat 0830: 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 -mutex* (make-mu 0840: 74 65 78 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d tex))..;;======= 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 3d 0a ===============. 0890: 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 0a 3b ;; S E R V E R.; 08a0: 3b 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 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define 08f0: 2d 69 6e 6c 69 6e 65 20 28 7a 6d 71 73 6f 63 6b -inline (zmqsock 0900: 3a 67 65 74 2d 70 75 62 20 20 64 61 74 29 28 76 :get-pub dat)(v 0910: 65 63 74 6f 72 2d 72 65 66 20 64 61 74 20 30 29 ector-ref dat 0) 0920: 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 ).(define-inline 0930: 20 28 7a 6d 71 73 6f 63 6b 3a 67 65 74 2d 70 75 (zmqsock:get-pu 0940: 6c 6c 20 64 61 74 29 28 76 65 63 74 6f 72 2d 72 ll dat)(vector-r 0950: 65 66 20 64 61 74 20 31 29 29 0a 28 64 65 66 69 ef dat 1)).(defi 0960: 6e 65 2d 69 6e 6c 69 6e 65 20 28 7a 6d 71 73 6f ne-inline (zmqso 0970: 63 6b 3a 73 65 74 2d 70 75 62 21 20 64 61 74 20 ck:set-pub! dat 0980: 73 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 64 s)(vector-set! d 0990: 61 74 20 73 20 30 29 29 0a 28 64 65 66 69 6e 65 at s 0)).(define 09a0: 2d 69 6e 6c 69 6e 65 20 28 7a 6d 71 73 6f 63 6b -inline (zmqsock 09b0: 3a 73 65 74 2d 70 75 6c 6c 21 20 64 61 74 20 73 :set-pull! dat s 09c0: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 64 61 )(vector-set! da 09d0: 74 20 73 20 30 29 29 0a 0a 28 64 65 66 69 6e 65 t s 0))..(define 09e0: 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a (zmq-transport: 09f0: 72 75 6e 20 68 6f 73 74 6e 29 0a 20 20 28 64 65 run hostn). (de 0a00: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 41 74 74 bug:print 2 "Att 0a10: 65 6d 70 74 69 6e 67 20 74 6f 20 73 74 61 72 74 empting to start 0a20: 20 74 68 65 20 73 65 72 76 65 72 20 2e 2e 2e 22 the server ..." 0a30: 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 6f ). (if (not *to 0a40: 70 70 61 74 68 2a 29 0a 20 20 20 20 20 20 28 69 ppath*). (i 0a50: 66 20 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f f (not (setup-fo 0a60: 72 2d 72 75 6e 29 29 0a 09 20 20 28 62 65 67 69 r-run)).. (begi 0a70: 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 n.. (debug:pr 0a80: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 63 61 int 0 "ERROR: ca 0a90: 6e 6e 6f 74 20 66 69 6e 64 20 6d 65 67 61 74 65 nnot find megate 0aa0: 73 74 2e 63 6f 6e 66 69 67 2c 20 63 61 6e 6e 6f st.config, canno 0ab0: 74 20 73 74 61 72 74 20 73 65 72 76 65 72 2c 20 t start server, 0ac0: 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 28 exiting").. ( 0ad0: 65 78 69 74 29 29 29 29 0a 20 20 28 6c 65 74 2a exit)))). (let* 0ae0: 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 20 ((db 0af0: 20 20 20 28 6f 70 65 6e 2d 64 62 29 29 20 3b 3b (open-db)) ;; 0b00: 20 68 65 72 65 20 77 65 20 2a 64 6f 20 6e 6f 74 here we *do not 0b10: 2a 20 77 61 6e 74 20 74 6f 20 62 65 20 6f 70 65 * want to be ope 0b20: 6e 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 ning and closing 0b30: 20 74 68 65 20 64 62 0a 09 20 28 7a 6d 71 2d 73 the db.. (zmq-s 0b40: 64 61 74 31 20 20 20 20 20 20 20 23 66 29 0a 09 dat1 #f).. 0b50: 20 28 7a 6d 71 2d 73 64 61 74 32 20 20 20 20 20 (zmq-sdat2 0b60: 20 20 23 66 29 0a 09 20 28 70 75 6c 6c 2d 73 6f #f).. (pull-so 0b70: 63 6b 65 74 20 20 20 20 20 23 66 29 0a 09 20 28 cket #f).. ( 0b80: 70 75 62 2d 73 6f 63 6b 65 74 20 20 20 20 20 20 pub-socket 0b90: 23 66 29 0a 09 20 28 70 31 20 20 20 20 20 20 20 #f).. (p1 0ba0: 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 70 32 #f).. (p2 0bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 #f 0bc0: 29 0a 09 20 28 7a 6d 71 2d 73 6f 63 6b 65 74 73 ).. (zmq-sockets 0bd0: 2d 64 61 74 20 23 66 29 0a 09 20 28 69 66 61 63 -dat #f).. (ifac 0be0: 65 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 e (if 0bf0: 28 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f (string=? "-" ho 0c00: 73 74 6e 29 0a 09 09 09 20 20 20 20 20 20 22 2a stn).... "* 0c10: 22 20 3b 3b 20 28 67 65 74 2d 68 6f 73 74 2d 6e " ;; (get-host-n 0c20: 61 6d 65 29 20 0a 09 09 09 20 20 20 20 20 20 68 ame) .... h 0c30: 6f 73 74 6e 29 29 0a 09 20 28 68 6f 73 74 6e 61 ostn)).. (hostna 0c40: 6d 65 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 me (get-h 0c50: 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 ost-name)).. (ip 0c60: 61 64 64 72 73 74 72 20 20 20 20 20 20 20 28 6c addrstr (l 0c70: 65 74 20 28 28 69 70 73 74 72 20 28 69 66 20 28 et ((ipstr (if ( 0c80: 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 string=? "-" hos 0c90: 74 6e 29 0a 09 09 09 09 09 20 20 20 28 73 74 72 tn)...... (str 0ca0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse 0cb0: 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 (map number->str 0cc0: 69 6e 67 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c ing (u8vector->l 0cd0: 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 ist (hostname->i 0ce0: 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 22 2e p hostname))) ". 0cf0: 22 29 0a 09 09 09 09 09 20 20 20 23 66 29 29 29 ")...... #f))) 0d00: 0a 09 09 09 20 20 20 20 28 69 66 20 69 70 73 74 .... (if ipst 0d10: 72 20 69 70 73 74 72 20 68 6f 73 74 6e 61 6d 65 r ipstr hostname 0d20: 29 29 29 0a 09 20 28 6c 61 73 74 2d 72 75 6e 20 ))).. (last-run 0d30: 20 20 20 20 20 20 30 29 29 0a 20 20 20 20 28 73 0)). (s 0d40: 65 74 21 20 7a 6d 71 2d 73 6f 63 6b 65 74 73 2d et! zmq-sockets- 0d50: 64 61 74 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f dat (zmq-transpo 0d60: 72 74 3a 73 65 74 75 70 2d 70 6f 72 74 73 20 69 rt:setup-ports i 0d70: 70 61 64 64 72 73 74 72 20 28 69 66 20 28 61 72 paddrstr (if (ar 0d80: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 6f 72 gs:get-arg "-por 0d90: 74 22 29 0a 09 09 09 20 20 20 20 28 73 74 72 69 t").... (stri 0da0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 61 72 67 73 ng->number (args 0db0: 3a 67 65 74 2d 61 72 67 20 22 2d 70 6f 72 74 22 :get-arg "-port" 0dc0: 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 28 2b ))........ (+ 0dd0: 20 35 30 30 30 20 28 72 61 6e 64 6f 6d 20 31 30 5000 (random 10 0de0: 30 31 29 29 29 29 29 0a 0a 20 20 20 20 28 73 65 01))))).. (se 0df0: 74 21 20 7a 6d 71 2d 73 64 61 74 31 20 20 20 20 t! zmq-sdat1 0e00: 28 63 61 72 20 20 20 7a 6d 71 2d 73 6f 63 6b 65 (car zmq-socke 0e10: 74 73 2d 64 61 74 29 29 0a 20 20 20 20 28 73 65 ts-dat)). (se 0e20: 74 21 20 70 75 6c 6c 2d 73 6f 63 6b 65 74 20 20 t! pull-socket 0e30: 28 63 61 64 72 20 20 7a 6d 71 2d 73 64 61 74 31 (cadr zmq-sdat1 0e40: 29 29 20 3b 3b 20 28 69 66 61 63 65 20 73 20 20 )) ;; (iface s 0e50: 70 6f 72 74 29 0a 20 20 20 20 28 73 65 74 21 20 port). (set! 0e60: 70 31 20 20 20 20 20 20 20 20 20 20 20 28 63 61 p1 (ca 0e70: 64 64 72 20 7a 6d 71 2d 73 64 61 74 31 29 29 0a ddr zmq-sdat1)). 0e80: 20 20 20 20 0a 20 20 20 20 28 73 65 74 21 20 7a . (set! z 0e90: 6d 71 2d 73 64 61 74 32 20 20 20 20 28 63 61 64 mq-sdat2 (cad 0ea0: 72 20 20 7a 6d 71 2d 73 6f 63 6b 65 74 73 2d 64 r zmq-sockets-d 0eb0: 61 74 29 29 0a 20 20 20 20 28 73 65 74 21 20 70 at)). (set! p 0ec0: 75 62 2d 73 6f 63 6b 65 74 20 20 20 28 63 61 64 ub-socket (cad 0ed0: 72 20 20 7a 6d 71 2d 73 64 61 74 32 29 29 0a 20 r zmq-sdat2)). 0ee0: 20 20 20 28 73 65 74 21 20 70 32 20 20 20 20 20 (set! p2 0ef0: 20 20 20 20 20 20 28 63 61 64 64 72 20 7a 6d 71 (caddr zmq 0f00: 2d 73 64 61 74 32 29 29 0a 0a 20 20 20 20 28 73 -sdat2)).. (s 0f10: 65 74 21 20 2a 63 61 63 68 65 2d 6f 6e 2a 20 23 et! *cache-on* # 0f20: 74 29 0a 0a 20 20 20 20 28 73 65 74 21 20 2a 72 t).. (set! *r 0f30: 75 6e 72 65 6d 6f 74 65 2a 20 28 76 65 63 74 6f unremote* (vecto 0f40: 72 20 70 75 6c 6c 2d 73 6f 63 6b 65 74 20 70 75 r pull-socket pu 0f50: 62 2d 73 6f 63 6b 65 74 29 29 20 3b 3b 20 6f 76 b-socket)) ;; ov 0f60: 65 72 6c 6f 61 64 69 6e 67 20 74 68 65 20 75 73 erloading the us 0f70: 65 20 6f 66 20 2a 72 75 6e 72 65 6d 6f 74 65 2a e of *runremote* 0f80: 20 42 55 47 21 3f 0a 0a 20 20 20 20 3b 3b 20 77 BUG!?.. ;; w 0f90: 68 61 74 20 74 6f 20 64 6f 20 77 68 65 6e 20 77 hat to do when w 0fa0: 65 20 71 75 69 74 0a 20 20 20 20 3b 3b 0a 3b 3b e quit. ;;.;; 0fb0: 20 20 20 20 20 28 6f 6e 2d 65 78 69 74 20 28 6c (on-exit (l 0fc0: 61 6d 62 64 61 20 28 29 0a 3b 3b 20 09 20 20 20 ambda ().;; . 0fd0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 2a 74 6f (if (and *to 0fe0: 70 70 61 74 68 2a 20 2a 73 65 72 76 65 72 2d 69 ppath* *server-i 0ff0: 6e 66 6f 2a 29 0a 3b 3b 20 09 09 20 20 20 28 6f nfo*).;; .. (o 1000: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 pen-run-close ta 1010: 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 72 65 67 sks:server-dereg 1020: 69 73 74 65 72 2d 73 65 6c 66 20 74 61 73 6b 73 ister-self tasks 1030: 3a 6f 70 65 6e 2d 64 62 20 28 63 61 72 20 2a 73 :open-db (car *s 1040: 65 72 76 65 72 2d 69 6e 66 6f 2a 29 29 0a 3b 3b erver-info*)).;; 1050: 20 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 .. (let loop 1060: 28 29 20 0a 3b 3b 20 09 09 20 20 20 20 20 28 6c () .;; .. (l 1070: 65 74 20 28 28 71 75 65 75 65 2d 6c 65 6e 20 30 et ((queue-len 0 1080: 29 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 20 28 )).;; .. ( 1090: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 72 thread-sleep! (r 10a0: 61 6e 64 6f 6d 20 35 29 29 0a 3b 3b 20 09 09 20 andom 5)).;; .. 10b0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 (mutex-loc 10c0: 6b 21 20 2a 69 6e 63 6f 6d 69 6e 67 2d 6d 75 74 k! *incoming-mut 10d0: 65 78 2a 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 ex*).;; .. 10e0: 20 28 73 65 74 21 20 71 75 65 75 65 2d 6c 65 6e (set! queue-len 10f0: 20 28 6c 65 6e 67 74 68 20 2a 69 6e 63 6f 6d 69 (length *incomi 1100: 6e 67 2d 64 61 74 61 2a 29 29 0a 3b 3b 20 09 09 ng-data*)).;; .. 1110: 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e (mutex-un 1120: 6c 6f 63 6b 21 20 2a 69 6e 63 6f 6d 69 6e 67 2d lock! *incoming- 1130: 6d 75 74 65 78 2a 29 0a 3b 3b 20 09 09 20 20 20 mutex*).;; .. 1140: 20 20 20 20 28 69 66 20 28 3e 20 71 75 65 75 65 (if (> queue 1150: 2d 6c 65 6e 20 30 29 0a 3b 3b 20 09 09 09 20 20 -len 0).;; ... 1160: 20 28 62 65 67 69 6e 0a 3b 3b 20 09 09 09 20 20 (begin.;; ... 1170: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print- 1180: 69 6e 66 6f 20 30 20 22 51 75 65 75 65 20 6e 6f info 0 "Queue no 1190: 74 20 66 6c 75 73 68 65 64 2c 20 77 61 69 74 69 t flushed, waiti 11a0: 6e 67 20 2e 2e 2e 22 29 0a 3b 3b 20 09 09 09 20 ng ...").;; ... 11b0: 20 20 20 20 28 6c 6f 6f 70 29 29 29 29 29 29 29 (loop))))))) 11c0: 29 0a 0a 20 20 20 20 3b 3b 20 54 68 65 20 68 65 ).. ;; The he 11d0: 61 76 79 20 6c 69 66 74 69 6e 67 0a 20 20 20 20 avy lifting. 11e0: 3b 3b 0a 20 20 20 20 3b 3b 20 6d 61 6b 65 2d 76 ;;. ;; make-v 11f0: 65 63 74 6f 72 2d 72 65 63 6f 72 64 20 63 64 62 ector-record cdb 1200: 20 70 61 63 6b 65 74 20 63 6c 69 65 6e 74 2d 73 packet client-s 1210: 69 67 20 71 74 79 70 65 20 69 6d 6d 65 64 69 61 ig qtype immedia 1220: 74 65 20 71 75 65 72 79 2d 73 69 67 20 70 61 72 te query-sig par 1230: 61 6d 73 20 71 74 69 6d 65 0a 20 20 20 20 3b 3b ams qtime. ;; 1240: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin 1250: 74 2d 69 6e 66 6f 20 31 31 20 22 53 65 72 76 65 t-info 11 "Serve 1260: 72 20 73 65 74 75 70 20 63 6f 6d 70 6c 65 74 65 r setup complete 1270: 2c 20 73 74 61 72 74 20 6c 69 73 74 65 6e 69 6e , start listenin 1280: 67 20 66 6f 72 20 6d 65 73 73 61 67 65 73 22 29 g for messages") 1290: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop ( 12a0: 28 71 75 65 75 65 2d 6c 73 74 20 27 28 29 29 29 (queue-lst '())) 12b0: 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 . (let* ((r 12c0: 61 77 6d 73 67 20 28 72 65 63 65 69 76 65 2d 6d awmsg (receive-m 12d0: 65 73 73 61 67 65 2a 20 70 75 6c 6c 2d 73 6f 63 essage* pull-soc 12e0: 6b 65 74 29 29 0a 09 20 20 20 20 20 28 70 61 63 ket)).. (pac 12f0: 6b 65 74 20 28 64 62 3a 73 74 72 69 6e 67 2d 3e ket (db:string-> 1300: 6f 62 6a 20 72 61 77 6d 73 67 29 29 0a 09 20 20 obj rawmsg)).. 1310: 20 20 20 28 71 74 79 70 65 20 20 28 63 64 62 3a (qtype (cdb: 1320: 70 61 63 6b 65 74 2d 67 65 74 2d 71 74 79 70 65 packet-get-qtype 1330: 20 70 61 63 6b 65 74 29 29 29 0a 09 28 64 65 62 packet)))..(deb 1340: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 ug:print-info 12 1350: 20 22 73 65 72 76 65 72 3d 3e 20 72 65 63 65 69 "server=> recei 1360: 76 65 64 20 70 61 63 6b 65 74 3d 22 20 70 61 63 ved packet=" pac 1370: 6b 65 74 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 ket)..(if (not ( 1380: 6d 65 6d 62 65 72 20 71 74 79 70 65 20 27 28 73 member qtype '(s 1390: 79 6e 63 20 70 69 6e 67 29 29 29 0a 09 20 20 20 ync ping))).. 13a0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. ( 13b0: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 mutex-lock! *hea 13c0: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 rtbeat-mutex*).. 13d0: 20 20 20 20 20 20 28 73 65 74 21 20 2a 6c 61 73 (set! *las 13e0: 74 2d 64 62 2d 61 63 63 65 73 73 2a 20 28 63 75 t-db-access* (cu 13f0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)). 1400: 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e . (mutex-un 1410: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat 1420: 2d 6d 75 74 65 78 2a 29 29 29 0a 09 28 69 66 20 -mutex*)))..(if 1430: 23 74 20 3b 3b 20 28 63 64 62 3a 70 61 63 6b 65 #t ;; (cdb:packe 1440: 74 2d 67 65 74 2d 69 6d 6d 65 64 69 61 74 65 20 t-get-immediate 1450: 70 61 63 6b 65 74 29 20 3b 3b 20 70 72 6f 63 65 packet) ;; proce 1460: 73 73 20 69 6d 6d 65 64 69 61 74 65 6c 79 20 6f ss immediately o 1470: 72 20 70 75 74 20 69 6e 20 71 75 65 75 65 0a 09 r put in queue.. 1480: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin.. 1490: 20 20 28 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 (db:process-qu 14a0: 65 75 65 2d 69 74 65 6d 20 64 62 20 70 61 63 6b eue-item db pack 14b0: 65 74 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 6f et).. ;; (o 14c0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db 14d0: 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 65 20 23 :process-queue # 14e0: 66 20 70 75 62 2d 73 6f 63 6b 65 74 20 28 63 6f f pub-socket (co 14f0: 6e 73 20 70 61 63 6b 65 74 20 71 75 65 75 65 2d ns packet queue- 1500: 6c 73 74 29 29 0a 09 20 20 20 20 20 20 0a 09 20 lst)).. .. 1510: 20 20 20 20 20 28 6c 6f 6f 70 20 27 28 29 29 29 (loop '())) 1520: 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 6f 6e .. (loop (con 1530: 73 20 70 61 63 6b 65 74 20 71 75 65 75 65 2d 6c s packet queue-l 1540: 73 74 29 29 29 29 29 29 29 0a 0a 3b 3b 20 72 75 st)))))))..;; ru 1550: 6e 20 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a n zmq-transport: 1560: 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 69 6e 20 keep-running in 1570: 61 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 a parallel threa 1580: 64 20 74 6f 20 6d 6f 6e 69 74 6f 72 20 74 68 61 d to monitor tha 1590: 74 20 74 68 65 20 64 62 20 69 73 20 62 65 69 6e t the db is bein 15a0: 67 20 0a 3b 3b 20 75 73 65 64 20 61 6e 64 20 74 g .;; used and t 15b0: 6f 20 73 68 75 74 64 6f 77 6e 20 61 66 74 65 72 o shutdown after 15c0: 20 73 6f 6d 65 74 69 6d 65 20 69 66 20 69 74 20 sometime if it 15d0: 69 73 20 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 66 69 is not..;;.(defi 15e0: 6e 65 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 ne (zmq-transpor 15f0: 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 29 0a t:keep-running). 1600: 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 75 6e ;; if none run 1610: 6e 69 6e 67 20 6f 72 20 69 66 20 3e 20 32 30 20 ning or if > 20 1620: 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 0a 20 seconds since . 1630: 20 3b 3b 20 73 65 72 76 65 72 20 6c 61 73 74 20 ;; server last 1640: 75 73 65 64 20 74 68 65 6e 20 73 74 61 72 74 20 used then start 1650: 73 68 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 68 shutdown. ;; Th 1660: 69 73 20 74 68 72 65 61 64 20 77 61 69 74 73 20 is thread waits 1670: 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 20 74 for the server t 1680: 6f 20 63 6f 6d 65 20 61 6c 69 76 65 0a 20 20 28 o come alive. ( 1690: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 69 6e let* ((server-in 16a0: 66 6f 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a fo (let loop (). 16b0: 09 09 09 28 6c 65 74 20 28 28 73 64 61 74 20 23 ...(let ((sdat # 16c0: 66 29 29 0a 09 09 09 20 20 28 6d 75 74 65 78 2d f)).... (mutex- 16d0: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat 16e0: 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 28 73 -mutex*).... (s 16f0: 65 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 et! sdat *server 1700: 2d 69 6e 66 6f 2a 29 0a 09 09 09 20 20 28 6d 75 -info*).... (mu 1710: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 tex-unlock! *hea 1720: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 rtbeat-mutex*).. 1730: 09 09 20 20 28 69 66 20 73 64 61 74 20 73 64 61 .. (if sdat sda 1740: 74 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 t.... (begi 1750: 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 n.....(debug:pri 1760: 6e 74 20 31 32 20 22 57 41 52 4e 49 4e 47 3a 20 nt 12 "WARNING: 1770: 73 65 72 76 65 72 20 6e 6f 74 20 73 74 61 72 74 server not start 1780: 65 64 20 79 65 74 2c 20 77 61 69 74 69 6e 67 20 ed yet, waiting 1790: 66 65 77 20 73 65 63 6f 6e 64 73 20 62 65 66 6f few seconds befo 17a0: 72 65 20 74 72 79 69 6e 67 20 61 67 61 69 6e 22 re trying again" 17b0: 29 0a 09 09 09 09 28 73 6c 65 65 70 20 34 29 0a ).....(sleep 4). 17c0: 09 09 09 09 28 6c 6f 6f 70 29 29 29 29 29 29 0a ....(loop)))))). 17d0: 09 20 28 69 66 61 63 65 20 20 20 20 20 20 20 28 . (iface ( 17e0: 63 61 64 72 20 73 65 72 76 65 72 2d 69 6e 66 6f cadr server-info 17f0: 29 29 0a 09 20 28 70 75 6c 6c 70 6f 72 74 20 20 )).. (pullport 1800: 20 20 28 63 61 64 64 72 20 73 65 72 76 65 72 2d (caddr server- 1810: 69 6e 66 6f 29 29 0a 09 20 28 70 75 62 70 6f 72 info)).. (pubpor 1820: 74 20 20 20 20 20 28 63 61 64 64 64 72 20 73 65 t (cadddr se 1830: 72 76 65 72 2d 69 6e 66 6f 29 29 20 3b 3b 20 69 rver-info)) ;; i 1840: 64 20 69 6e 74 65 72 66 61 63 65 20 70 75 6c 6c d interface pull 1850: 70 6f 72 74 20 70 75 62 70 6f 72 74 29 0a 09 20 port pubport).. 1860: 3b 3b 20 28 7a 6d 71 2d 73 6f 63 6b 65 74 73 20 ;; (zmq-sockets 1870: 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 (zmq-transport:c 1880: 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 lient-connect if 1890: 61 63 65 20 70 75 6c 6c 70 6f 72 74 20 70 75 62 ace pullport pub 18a0: 70 6f 72 74 29 29 0a 09 20 28 6c 61 73 74 2d 61 port)).. (last-a 18b0: 63 63 65 73 73 20 30 29 29 0a 20 20 20 20 28 64 ccess 0)). (d 18c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info 18d0: 31 31 20 22 68 65 61 72 74 62 65 61 74 20 73 74 11 "heartbeat st 18e0: 61 72 74 65 64 20 66 6f 72 20 7a 6d 71 20 73 65 arted for zmq se 18f0: 72 76 65 72 20 6f 6e 20 22 20 69 66 61 63 65 20 rver on " iface 1900: 22 20 22 20 70 75 6c 6c 70 6f 72 74 20 22 20 22 " " pullport " " 1910: 20 70 75 62 70 6f 72 74 29 0a 20 20 20 20 28 6c pubport). (l 1920: 65 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 et loop ((count 1930: 30 29 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 0)). (threa 1940: 64 2d 73 6c 65 65 70 21 20 34 29 20 3b 3b 20 6e d-sleep! 4) ;; n 1950: 6f 20 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 69 o need to do thi 1960: 73 20 76 65 72 79 20 6f 66 74 65 6e 0a 20 20 20 s very often. 1970: 20 20 20 3b 3b 20 4e 42 2f 2f 20 73 79 6e 63 20 ;; NB// sync 1980: 63 75 72 72 65 6e 74 6c 79 20 64 6f 65 73 20 4e currently does N 1990: 4f 54 20 72 65 74 75 72 6e 20 71 75 65 75 65 2d OT return queue- 19a0: 6c 65 6e 67 74 68 0a 20 20 20 20 20 20 3b 3b 20 length. ;; 19b0: 47 45 54 20 52 45 41 4c 20 51 55 45 55 45 20 4c GET REAL QUEUE L 19c0: 45 4e 47 54 48 20 46 52 4f 4d 20 54 48 45 20 56 ENGTH FROM THE V 19d0: 41 52 49 41 42 4c 45 0a 20 20 20 20 20 20 28 6c ARIABLE. (l 19e0: 65 74 20 28 28 71 75 65 75 65 2d 6c 65 6e 20 30 et ((queue-len 0 19f0: 29 29 20 3b 3b 20 46 4f 52 20 4e 4f 57 20 44 4f )) ;; FOR NOW DO 1a00: 20 4e 4f 54 20 44 4f 20 54 48 49 53 20 28 63 64 NOT DO THIS (cd 1a10: 62 3a 63 6c 69 65 6e 74 2d 63 61 6c 6c 20 7a 6d b:client-call zm 1a20: 71 2d 73 6f 63 6b 65 74 73 20 27 73 79 6e 63 20 q-sockets 'sync 1a30: 23 74 20 31 29 29 29 0a 20 20 20 20 20 20 3b 3b #t 1))). ;; 1a40: 20 28 70 72 69 6e 74 20 22 53 65 72 76 65 72 20 (print "Server 1a50: 72 75 6e 6e 69 6e 67 2c 20 63 6f 75 6e 74 20 69 running, count i 1a60: 73 20 22 20 63 6f 75 6e 74 29 0a 09 28 69 66 20 s " count)..(if 1a70: 28 3c 20 63 6f 75 6e 74 20 31 29 20 3b 3b 20 33 (< count 1) ;; 3 1a80: 78 33 20 3d 20 39 20 73 65 63 73 20 61 70 72 6f x3 = 9 secs apro 1a90: 78 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 x.. (loop (+ 1aa0: 63 6f 75 6e 74 20 31 29 29 29 0a 0a 09 3b 3b 20 count 1)))...;; 1ab0: 4e 4f 54 45 3a 20 47 65 74 20 72 69 64 20 6f 66 NOTE: Get rid of 1ac0: 20 74 68 69 73 20 6d 65 63 68 61 6e 69 73 6d 21 this mechanism! 1ad0: 20 49 74 20 72 65 61 6c 6c 79 20 69 73 20 6e 6f It really is no 1ae0: 74 20 6e 65 65 64 65 64 2e 2e 2e 0a 09 28 6f 70 t needed.....(op 1af0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 en-run-close tas 1b00: 6b 73 3a 73 65 72 76 65 72 2d 75 70 64 61 74 65 ks:server-update 1b10: 2d 68 65 61 72 74 62 65 61 74 20 74 61 73 6b 73 -heartbeat tasks 1b20: 3a 6f 70 65 6e 2d 64 62 20 28 63 61 72 20 73 65 :open-db (car se 1b30: 72 76 65 72 2d 69 6e 66 6f 29 29 0a 0a 09 3b 3b rver-info))...;; 1b40: 20 28 69 66 20 3b 3b 20 28 6f 72 20 28 3e 20 6e (if ;; (or (> n 1b50: 75 6d 72 75 6e 6e 69 6e 67 20 30 29 20 3b 3b 20 umrunning 0) ;; 1b60: 73 74 61 79 20 61 6c 69 76 65 20 66 6f 72 20 74 stay alive for t 1b70: 77 6f 20 64 61 79 73 20 61 66 74 65 72 20 6c 61 wo days after la 1b80: 73 74 20 61 63 63 65 73 73 0a 09 28 6d 75 74 65 st access..(mute 1b90: 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 x-lock! *heartbe 1ba0: 61 74 2d 6d 75 74 65 78 2a 29 0a 09 28 73 65 74 at-mutex*)..(set 1bb0: 21 20 6c 61 73 74 2d 61 63 63 65 73 73 20 2a 6c ! last-access *l 1bc0: 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 29 0a ast-db-access*). 1bd0: 09 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 .(mutex-unlock! 1be0: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex 1bf0: 2a 29 0a 09 28 69 66 20 28 3e 20 28 2b 20 6c 61 *)..(if (> (+ la 1c00: 73 74 2d 61 63 63 65 73 73 0a 09 09 20 20 3b 3b st-access... ;; 1c10: 20 28 2a 20 35 30 20 36 30 20 36 30 29 20 20 20 (* 50 60 60) 1c20: 20 3b 3b 20 34 38 20 68 72 73 0a 09 09 20 20 3b ;; 48 hrs... ; 1c30: 3b 20 36 30 20 20 20 20 20 20 20 20 20 20 20 20 ; 60 1c40: 20 20 3b 3b 20 6f 6e 65 20 6d 69 6e 75 74 65 0a ;; one minute. 1c50: 09 09 20 20 3b 3b 20 28 2a 20 36 30 20 36 30 29 .. ;; (* 60 60) 1c60: 20 20 20 20 20 20 20 3b 3b 20 6f 6e 65 20 68 6f ;; one ho 1c70: 75 72 0a 09 09 20 20 28 2a 20 34 35 20 36 30 29 ur... (* 45 60) 1c80: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 34 35 20 ;; 45 1c90: 6d 69 6e 75 74 65 73 2c 20 75 6e 74 69 6c 20 74 minutes, until t 1ca0: 68 65 20 64 62 20 64 65 6c 65 74 69 6f 6e 20 62 he db deletion b 1cb0: 75 67 20 69 73 20 66 69 78 65 64 2e 0a 09 09 20 ug is fixed.... 1cc0: 20 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 ).. (curr 1cd0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 ent-seconds)).. 1ce0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin.. 1cf0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in 1d00: 66 6f 20 32 20 22 53 65 72 76 65 72 20 63 6f 6e fo 2 "Server con 1d10: 74 69 6e 75 69 6e 67 2c 20 73 65 63 6f 6e 64 73 tinuing, seconds 1d20: 20 73 69 6e 63 65 20 6c 61 73 74 20 64 62 20 61 since last db a 1d30: 63 63 65 73 73 3a 20 22 20 28 2d 20 28 63 75 72 ccess: " (- (cur 1d40: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 rent-seconds) la 1d50: 73 74 2d 61 63 63 65 73 73 29 29 0a 09 20 20 20 st-access)).. 1d60: 20 20 20 28 6c 6f 6f 70 20 30 29 29 0a 09 20 20 (loop 0)).. 1d70: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin.. 1d80: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf 1d90: 6f 20 30 20 22 53 74 61 72 74 69 6e 67 20 74 6f o 0 "Starting to 1da0: 20 73 68 75 74 64 6f 77 6e 20 74 68 65 20 73 65 shutdown the se 1db0: 72 76 65 72 2e 22 29 0a 09 20 20 20 20 20 20 3b rver.").. ; 1dc0: 3b 20 6e 65 65 64 20 74 6f 20 64 65 6c 65 74 65 ; need to delete 1dd0: 20 6f 6e 6c 79 20 2a 6d 79 2a 20 73 65 72 76 65 only *my* serve 1de0: 72 20 65 6e 74 72 79 20 28 66 75 74 75 72 65 20 r entry (future 1df0: 75 73 65 29 0a 09 20 20 20 20 20 20 28 73 65 74 use).. (set 1e00: 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a ! *time-to-exit* 1e10: 20 23 74 29 0a 09 20 20 20 20 20 20 28 6f 70 65 #t).. (ope 1e20: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b n-run-close task 1e30: 73 3a 73 65 72 76 65 72 2d 64 65 72 65 67 69 73 s:server-deregis 1e40: 74 65 72 2d 73 65 6c 66 20 74 61 73 6b 73 3a 6f ter-self tasks:o 1e50: 70 65 6e 2d 64 62 20 28 67 65 74 2d 68 6f 73 74 pen-db (get-host 1e60: 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 28 -name)).. ( 1e70: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1) 1e80: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p 1e90: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4d 61 78 rint-info 0 "Max 1ea0: 20 63 61 63 68 65 64 20 71 75 65 72 69 65 73 20 cached queries 1eb0: 77 61 73 20 22 20 2a 6d 61 78 2d 63 61 63 68 65 was " *max-cache 1ec0: 2d 73 69 7a 65 2a 29 0a 09 20 20 20 20 20 20 28 -size*).. ( 1ed0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info 1ee0: 20 30 20 22 53 65 72 76 65 72 20 73 68 75 74 64 0 "Server shutd 1ef0: 6f 77 6e 20 63 6f 6d 70 6c 65 74 65 2e 20 45 78 own complete. Ex 1f00: 69 74 69 6e 67 22 29 0a 09 20 20 20 20 20 20 28 iting").. ( 1f10: 65 78 69 74 29 29 29 29 29 29 29 0a 0a 28 64 65 exit)))))))..(de 1f20: 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 6e 73 70 fine (zmq-transp 1f30: 6f 72 74 3a 66 69 6e 64 2d 66 72 65 65 2d 70 6f ort:find-free-po 1f40: 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 69 66 61 63 rt-and-open ifac 1f50: 65 20 73 20 70 6f 72 74 20 73 74 79 70 65 20 23 e s port stype # 1f60: 21 6b 65 79 20 28 74 72 79 6e 75 6d 20 35 30 29 !key (trynum 50) 1f70: 29 0a 20 20 28 6c 65 74 20 28 28 73 20 28 69 66 ). (let ((s (if 1f80: 20 73 20 73 20 28 6d 61 6b 65 2d 73 6f 63 6b 65 s s (make-socke 1f90: 74 20 73 74 79 70 65 29 29 29 0a 20 20 20 20 20 t stype))). 1fa0: 20 20 20 28 70 20 28 69 66 20 28 6e 75 6d 62 65 (p (if (numbe 1fb0: 72 3f 20 70 6f 72 74 29 20 70 6f 72 74 20 35 35 r? port) port 55 1fc0: 35 35 29 29 0a 20 20 20 20 20 20 20 20 28 6f 6c 55)). (ol 1fd0: 64 2d 68 61 6e 64 6c 65 72 20 28 63 75 72 72 65 d-handler (curre 1fe0: 6e 74 2d 65 78 63 65 70 74 69 6f 6e 2d 68 61 6e nt-exception-han 1ff0: 64 6c 65 72 29 29 29 0a 20 20 20 20 28 68 61 6e dler))). (han 2000: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions. 2010: 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 62 65 exn. (be 2020: 67 69 6e 0a 20 20 20 20 20 20 20 28 64 65 62 75 gin. (debu 2030: 67 3a 70 72 69 6e 74 20 30 20 22 46 61 69 6c 65 g:print 0 "Faile 2040: 64 20 74 6f 20 62 69 6e 64 20 74 6f 20 70 6f 72 d to bind to por 2050: 74 20 22 20 70 20 22 2c 20 74 72 79 69 6e 67 20 t " p ", trying 2060: 6e 65 78 74 20 70 6f 72 74 22 29 0a 20 20 20 20 next port"). 2070: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print 2080: 30 20 22 20 20 20 45 58 43 45 50 54 49 4f 4e 3a 0 " EXCEPTION: 2090: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p 20a0: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor 20b0: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message) 20c0: 65 78 6e 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 exn)). ;; 20d0: 28 6f 6c 64 2d 68 61 6e 64 6c 65 72 29 0a 20 20 (old-handler). 20e0: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 2d 63 ;; (print-c 20f0: 61 6c 6c 2d 63 68 61 69 6e 29 0a 20 20 20 20 20 all-chain). 2100: 20 20 28 69 66 20 28 3e 20 74 72 79 6e 75 6d 20 (if (> trynum 2110: 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 7a 0). (z 2120: 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 66 69 6e mq-transport:fin 2130: 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e 64 2d d-free-port-and- 2140: 6f 70 65 6e 20 69 66 61 63 65 20 73 20 28 2b 20 open iface s (+ 2150: 70 20 31 29 20 74 72 79 6e 75 6d 3a 20 28 2d 20 p 1) trynum: (- 2160: 74 72 79 6e 75 6d 20 31 29 29 0a 20 20 20 20 20 trynum 1)). 2170: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri 2180: 6e 74 2d 69 6e 66 6f 20 30 20 22 54 72 69 65 64 nt-info 0 "Tried 2190: 20 70 6f 72 74 73 20 75 70 20 74 6f 20 22 20 70 ports up to " p 21a0: 20 0a 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 20 22 " 21c0: 20 62 75 74 20 61 6c 6c 20 77 65 72 65 20 69 6e but all were in 21d0: 20 75 73 65 2e 20 50 6c 65 61 73 65 20 74 72 79 use. Please try 21e0: 20 61 20 64 69 66 66 65 72 65 6e 74 20 70 6f 72 a different por 21f0: 74 20 72 61 6e 67 65 20 62 79 20 73 74 61 72 74 t range by start 2200: 69 6e 67 20 74 68 65 20 73 65 72 76 65 72 20 77 ing the server w 2210: 69 74 68 20 70 61 72 61 6d 65 74 65 72 20 5c 22 ith parameter \" 2220: 20 2d 70 6f 72 74 20 4e 5c 22 20 77 68 65 72 65 -port N\" where 2230: 20 4e 20 69 73 20 74 68 65 20 73 74 61 72 74 69 N is the starti 2240: 6e 67 20 70 6f 72 74 20 6e 75 6d 62 65 72 20 74 ng port number t 2250: 6f 20 75 73 65 22 29 29 0a 20 20 20 20 20 20 20 o use")). 2260: 28 65 78 69 74 29 29 20 3b 3b 20 54 6f 20 65 78 (exit)) ;; To ex 2270: 69 74 20 6f 72 20 6e 6f 74 3f 20 54 68 61 74 20 it or not? That 2280: 69 73 20 74 68 65 20 71 75 65 73 74 69 6f 6e 2e is the question. 2290: 0a 20 20 20 20 20 28 6c 65 74 20 28 28 7a 6d 71 . (let ((zmq 22a0: 2d 75 72 6c 20 28 63 6f 6e 63 20 22 74 63 70 3a -url (conc "tcp: 22b0: 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 29 //" iface ":" p) 22c0: 29 29 0a 20 20 20 20 20 20 20 28 64 65 62 75 67 )). (debug 22d0: 3a 70 72 69 6e 74 20 32 20 22 54 72 79 69 6e 67 :print 2 "Trying 22e0: 20 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 to start server 22f0: 20 6f 6e 20 22 20 7a 6d 71 2d 75 72 6c 29 0a 20 on " zmq-url). 2300: 20 20 20 20 20 20 28 62 69 6e 64 2d 73 6f 63 6b (bind-sock 2310: 65 74 20 73 20 7a 6d 71 2d 75 72 6c 29 0a 20 20 et s zmq-url). 2320: 20 20 20 20 20 28 6c 69 73 74 20 69 66 61 63 65 (list iface 2330: 20 73 20 70 6f 72 74 29 29 29 29 29 0a 0a 28 64 s port)))))..(d 2340: 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 6e 73 efine (zmq-trans 2350: 70 6f 72 74 3a 73 65 74 75 70 2d 70 6f 72 74 73 port:setup-ports 2360: 20 69 70 61 64 64 72 73 74 72 20 73 74 61 72 74 ipaddrstr start 2370: 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 port). (let* (( 2380: 73 31 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 s1 (zmq-transpor 2390: 74 3a 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 t:find-free-port 23a0: 2d 61 6e 64 2d 6f 70 65 6e 20 69 70 61 64 64 72 -and-open ipaddr 23b0: 73 74 72 20 23 66 20 73 74 61 72 74 70 6f 72 74 str #f startport 23c0: 20 27 70 75 6c 6c 29 29 0a 20 20 20 20 20 20 20 'pull)). 23d0: 20 20 28 70 31 20 28 63 61 64 64 72 20 73 31 29 (p1 (caddr s1) 23e0: 29 0a 20 20 20 20 20 20 20 20 20 28 73 32 20 28 ). (s2 ( 23f0: 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 66 69 zmq-transport:fi 2400: 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e 64 nd-free-port-and 2410: 2d 6f 70 65 6e 20 69 70 61 64 64 72 73 74 72 20 -open ipaddrstr 2420: 23 66 20 28 2b 20 31 20 28 69 66 20 70 31 20 70 #f (+ 1 (if p1 p 2430: 31 20 28 2b 20 73 74 61 72 74 70 6f 72 74 20 31 1 (+ startport 1 2440: 29 29 29 20 27 70 75 62 29 29 0a 20 20 20 20 20 ))) 'pub)). 2450: 20 20 20 20 28 70 32 20 28 63 61 64 64 72 20 73 (p2 (caddr s 2460: 32 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 2))). (set! * 2470: 72 75 6e 72 65 6d 6f 74 65 2a 20 23 66 29 0a 20 runremote* #f). 2480: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print 2490: 30 20 22 53 65 72 76 65 72 20 73 74 61 72 74 65 0 "Server starte 24a0: 64 20 6f 6e 20 22 20 69 70 61 64 64 72 73 74 72 d on " ipaddrstr 24b0: 20 22 20 70 6f 72 74 73 20 22 20 70 31 20 22 20 " ports " p1 " 24c0: 61 6e 64 20 22 20 70 32 29 0a 20 20 20 20 28 6d and " p2). (m 24d0: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 utex-lock! *hear 24e0: 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 tbeat-mutex*). 24f0: 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d (set! *server- 2500: 69 6e 66 6f 2a 20 28 6f 70 65 6e 2d 72 75 6e 2d info* (open-run- 2510: 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 close tasks:serv 2520: 65 72 2d 72 65 67 69 73 74 65 72 20 0a 09 09 09 er-register .... 2530: 09 09 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 ..tasks:open-db 2540: 0a 09 09 09 09 09 28 63 75 72 72 65 6e 74 2d 70 ......(current-p 2550: 72 6f 63 65 73 73 2d 69 64 29 20 0a 09 09 09 09 rocess-id) ..... 2560: 09 69 70 61 64 64 72 73 74 72 20 70 31 20 0a 09 .ipaddrstr p1 .. 2570: 09 09 09 09 30 20 0a 09 09 09 09 09 27 6c 69 76 ....0 ......'liv 2580: 65 0a 09 09 09 09 09 27 7a 6d 71 0a 09 09 09 09 e......'zmq..... 2590: 09 70 75 62 70 6f 72 74 3a 20 70 32 29 29 0a 20 .pubport: p2)). 25a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print- 25b0: 69 6e 66 6f 20 31 31 20 22 2a 73 65 72 76 65 72 info 11 "*server 25c0: 2d 69 6e 66 6f 2a 20 73 65 74 20 74 6f 20 22 20 -info* set to " 25d0: 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 0a 20 *server-info*). 25e0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock 25f0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut 2600: 65 78 2a 29 0a 20 20 20 20 28 6c 69 73 74 20 73 ex*). (list s 2610: 31 20 73 32 29 29 29 0a 0a 28 64 65 66 69 6e 65 1 s2)))..(define 2620: 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a (zmq-transport: 2630: 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 mk-signature). 2640: 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d (message-digest- 2650: 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d string (md5-prim 2660: 69 74 69 76 65 29 20 0a 09 09 09 20 28 77 69 74 itive) .... (wit 2670: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 h-output-to-stri 2680: 6e 67 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 61 ng.... (lambda 2690: 20 28 29 0a 09 09 09 20 20 20 20 20 28 77 72 69 ().... (wri 26a0: 74 65 20 28 6c 69 73 74 20 28 63 75 72 72 65 6e te (list (curren 26b0: 74 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 09 09 t-directory).... 26c0: 09 09 20 20 28 61 72 67 76 29 29 29 29 29 29 29 .. (argv))))))) 26d0: 0a 0a 3b 3b 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 3d 0a 3b 3b 20 53 20 ==========.;; S 2720: 45 20 52 20 56 20 45 20 52 20 20 20 55 20 54 20 E R V E R U T 2730: 49 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a 3b I L I T I E S .; 2740: 3b 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 3d 0a 0a 3b 3b 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: 3d 0a 3b 3b 20 43 20 4c 20 49 20 45 20 4e 20 54 =.;; C L I E N T 27e0: 20 53 0a 3b 3b 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 3d 0a 0a 3b 3b 20 ===========..;; 2830: 0a 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 .(define (zmq-tr 2840: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 ansport:client-s 2850: 6f 63 6b 65 74 2d 63 6f 6e 6e 65 63 74 20 69 66 ocket-connect if 2860: 61 63 65 20 70 6f 72 74 20 23 21 6b 65 79 20 28 ace port #!key ( 2870: 63 6f 6e 74 65 78 74 20 23 66 29 28 74 79 70 65 context #f)(type 2880: 20 27 72 65 71 29 28 73 75 62 73 63 72 69 70 74 'req)(subscript 2890: 69 6f 6e 73 20 27 28 29 29 29 0a 20 20 28 64 65 ions '())). (de 28a0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 bug:print-info 3 28b0: 20 22 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 "client-connect 28c0: 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 " iface ":" por 28d0: 74 20 22 2c 20 74 79 70 65 3d 22 20 74 79 70 65 t ", type=" type 28e0: 20 22 2c 20 73 75 62 73 63 72 69 70 74 69 6f 6e ", subscription 28f0: 73 3d 22 20 73 75 62 73 63 72 69 70 74 69 6f 6e s=" subscription 2900: 73 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e s). (let ((conn 2910: 65 63 74 2d 6f 6b 20 23 66 29 0a 09 28 7a 6d 71 ect-ok #f)..(zmq 2920: 2d 73 6f 63 6b 65 74 20 28 69 66 20 63 6f 6e 74 -socket (if cont 2930: 65 78 74 20 0a 09 09 09 28 6d 61 6b 65 2d 73 6f ext ....(make-so 2940: 63 6b 65 74 20 74 79 70 65 20 63 6f 6e 74 65 78 cket type contex 2950: 74 29 0a 09 09 09 28 6d 61 6b 65 2d 73 6f 63 6b t)....(make-sock 2960: 65 74 20 74 79 70 65 29 29 29 0a 09 28 63 6f 6e et type)))..(con 2970: 75 72 6c 20 20 20 20 20 28 7a 6d 71 2d 74 72 61 url (zmq-tra 2980: 6e 73 70 6f 72 74 3a 6d 61 6b 65 2d 73 65 72 76 nsport:make-serv 2990: 65 72 2d 75 72 6c 20 28 6c 69 73 74 20 69 66 61 er-url (list ifa 29a0: 63 65 20 70 6f 72 74 29 29 29 29 0a 20 20 20 20 ce port)))). 29b0: 28 69 66 20 28 73 6f 63 6b 65 74 3f 20 7a 6d 71 (if (socket? zmq 29c0: 2d 73 6f 63 6b 65 74 29 0a 20 20 20 20 20 28 62 -socket). (b 29d0: 65 67 69 6e 0a 09 20 20 3b 3b 20 66 69 72 73 74 egin.. ;; first 29e0: 20 61 70 70 6c 79 20 73 75 62 73 63 72 69 70 74 apply subscript 29f0: 69 6f 6e 73 0a 09 20 20 28 66 6f 72 2d 65 61 63 ions.. (for-eac 2a00: 68 20 28 6c 61 6d 62 64 61 20 28 73 75 62 73 63 h (lambda (subsc 2a10: 72 69 70 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 ription)... 2a20: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2 2a30: 22 53 75 62 73 63 72 69 62 69 6e 67 20 74 6f 20 "Subscribing to 2a40: 22 20 73 75 62 73 63 72 69 70 74 69 6f 6e 29 0a " subscription). 2a50: 09 09 20 20 20 20 20 20 28 73 6f 63 6b 65 74 2d .. (socket- 2a60: 6f 70 74 69 6f 6e 2d 73 65 74 21 20 7a 6d 71 2d option-set! zmq- 2a70: 73 6f 63 6b 65 74 20 27 73 75 62 73 63 72 69 62 socket 'subscrib 2a80: 65 20 73 75 62 73 63 72 69 70 74 69 6f 6e 29 29 e subscription)) 2a90: 0a 09 09 20 20 20 20 73 75 62 73 63 72 69 70 74 ... subscript 2aa0: 69 6f 6e 73 29 0a 09 20 20 28 63 6f 6e 6e 65 63 ions).. (connec 2ab0: 74 2d 73 6f 63 6b 65 74 20 7a 6d 71 2d 73 6f 63 t-socket zmq-soc 2ac0: 6b 65 74 20 63 6f 6e 75 72 6c 29 0a 09 20 20 7a ket conurl).. z 2ad0: 6d 71 2d 73 6f 63 6b 65 74 29 0a 09 28 62 65 67 mq-socket)..(beg 2ae0: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri 2af0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 nt 0 "ERROR: Fai 2b00: 6c 65 64 20 74 6f 20 6f 70 65 6e 20 73 6f 63 6b led to open sock 2b10: 65 74 20 74 6f 20 22 20 63 6f 6e 75 72 6c 29 0a et to " conurl). 2b20: 09 20 20 23 66 29 29 29 29 0a 0a 28 64 65 66 69 . #f))))..(defi 2b30: 6e 65 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 ne (zmq-transpor 2b40: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect 2b50: 20 69 66 61 63 65 20 70 75 6c 6c 70 6f 72 74 20 iface pullport 2b60: 70 75 62 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a pubport). (let* 2b70: 20 28 28 70 75 73 68 2d 73 6f 63 6b 65 74 20 28 ((push-socket ( 2b80: 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c zmq-transport:cl 2b90: 69 65 6e 74 2d 73 6f 63 6b 65 74 2d 63 6f 6e 6e ient-socket-conn 2ba0: 65 63 74 20 69 66 61 63 65 20 70 75 6c 6c 70 6f ect iface pullpo 2bb0: 72 74 20 74 79 70 65 3a 20 27 70 75 73 68 29 29 rt type: 'push)) 2bc0: 0a 09 20 28 73 75 62 2d 73 6f 63 6b 65 74 20 20 .. (sub-socket 2bd0: 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 (zmq-transport:c 2be0: 6c 69 65 6e 74 2d 73 6f 63 6b 65 74 2d 63 6f 6e lient-socket-con 2bf0: 6e 65 63 74 20 69 66 61 63 65 20 70 75 62 70 6f nect iface pubpo 2c00: 72 74 0a 09 09 09 09 09 09 20 20 20 20 74 79 70 rt....... typ 2c10: 65 3a 20 27 73 75 62 0a 09 09 09 09 09 09 20 20 e: 'sub....... 2c20: 20 20 73 75 62 73 63 72 69 70 74 69 6f 6e 73 3a subscriptions: 2c30: 20 28 6c 69 73 74 20 28 63 6c 69 65 6e 74 3a 67 (list (client:g 2c40: 65 74 2d 73 69 67 6e 61 74 75 72 65 29 20 22 61 et-signature) "a 2c50: 6c 6c 22 29 29 29 0a 09 20 28 7a 6d 71 2d 73 6f ll"))).. (zmq-so 2c60: 63 6b 65 74 73 20 28 76 65 63 74 6f 72 20 70 75 ckets (vector pu 2c70: 73 68 2d 73 6f 63 6b 65 74 20 73 75 62 2d 73 6f sh-socket sub-so 2c80: 63 6b 65 74 29 29 0a 09 20 28 6c 6f 67 69 6e 2d cket)).. (login- 2c90: 72 65 73 20 20 20 23 66 29 29 0a 20 20 20 20 28 res #f)). ( 2ca0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info 2cb0: 20 31 31 20 22 7a 6d 71 2d 74 72 61 6e 73 70 6f 11 "zmq-transpo 2cc0: 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 rt:client-connec 2cd0: 74 20 73 74 61 72 74 65 64 2e 20 4e 65 78 74 20 t started. Next 2ce0: 69 73 20 6c 6f 67 69 6e 22 29 0a 20 20 20 20 28 is login"). ( 2cf0: 73 65 74 21 20 6c 6f 67 69 6e 2d 72 65 73 20 28 set! login-res ( 2d00: 63 6c 69 65 6e 74 3a 6c 6f 67 69 6e 20 73 65 72 client:login ser 2d10: 76 65 72 64 61 74 20 7a 6d 71 2d 73 6f 63 6b 65 verdat zmq-socke 2d20: 74 73 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e ts)). (if (an 2d30: 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6c 6f d (not (null? lo 2d40: 67 69 6e 2d 72 65 73 29 29 0a 09 20 20 20 20 20 gin-res)).. 2d50: 28 63 61 72 20 6c 6f 67 69 6e 2d 72 65 73 29 29 (car login-res)) 2d60: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb 2d70: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2 2d80: 22 4c 6f 67 67 65 64 20 69 6e 20 61 6e 64 20 63 "Logged in and c 2d90: 6f 6e 6e 65 63 74 65 64 20 74 6f 20 22 20 69 66 onnected to " if 2da0: 61 63 65 20 22 3a 22 20 70 75 6c 6c 70 6f 72 74 ace ":" pullport 2db0: 20 22 2f 22 20 70 75 62 70 6f 72 74 20 22 2e 22 "/" pubport "." 2dc0: 29 0a 09 20 20 28 73 65 74 21 20 2a 72 75 6e 72 ).. (set! *runr 2dd0: 65 6d 6f 74 65 2a 20 7a 6d 71 2d 73 6f 63 6b 65 emote* zmq-socke 2de0: 74 73 29 0a 09 20 20 7a 6d 71 2d 73 6f 63 6b 65 ts).. zmq-socke 2df0: 74 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 ts)..(begin.. ( 2e00: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info 2e10: 20 32 20 22 46 61 69 6c 65 64 20 74 6f 20 6c 6f 2 "Failed to lo 2e20: 67 69 6e 20 6f 72 20 63 6f 6e 6e 65 63 74 20 74 gin or connect t 2e30: 6f 20 22 20 63 6f 6e 75 72 6c 29 0a 09 20 20 28 o " conurl).. ( 2e40: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote* 2e50: 20 23 66 29 0a 09 20 20 23 66 29 29 29 29 0a 0a #f).. #f)))).. 2e60: 3b 3b 20 72 75 6e 20 7a 6d 71 2d 74 72 61 6e 73 ;; run zmq-trans 2e70: 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e port:keep-runnin 2e80: 67 20 69 6e 20 61 20 70 61 72 61 6c 6c 65 6c 20 g in a parallel 2e90: 74 68 72 65 61 64 20 74 6f 20 6d 6f 6e 69 74 6f thread to monito 2ea0: 72 20 74 68 61 74 20 74 68 65 20 64 62 20 69 73 r that the db is 2eb0: 20 62 65 69 6e 67 20 0a 3b 3b 20 75 73 65 64 20 being .;; used 2ec0: 61 6e 64 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 and to shutdown 2ed0: 61 66 74 65 72 20 73 6f 6d 65 74 69 6d 65 20 69 after sometime i 2ee0: 66 20 69 74 20 69 73 20 6e 6f 74 2e 0a 3b 3b 0a f it is not..;;. 2ef0: 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 (define (zmq-tra 2f00: 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e nsport:keep-runn 2f10: 69 6e 67 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 6e ing). ;; if non 2f20: 65 20 72 75 6e 6e 69 6e 67 20 6f 72 20 69 66 20 e running or if 2f30: 3e 20 32 30 20 73 65 63 6f 6e 64 73 20 73 69 6e > 20 seconds sin 2f40: 63 65 20 0a 20 20 3b 3b 20 73 65 72 76 65 72 20 ce . ;; server 2f50: 6c 61 73 74 20 75 73 65 64 20 74 68 65 6e 20 73 last used then s 2f60: 74 61 72 74 20 73 68 75 74 64 6f 77 6e 0a 20 20 tart shutdown. 2f70: 3b 3b 20 54 68 69 73 20 74 68 72 65 61 64 20 77 ;; This thread w 2f80: 61 69 74 73 20 66 6f 72 20 74 68 65 20 73 65 72 aits for the ser 2f90: 76 65 72 20 74 6f 20 63 6f 6d 65 20 61 6c 69 76 ver to come aliv 2fa0: 65 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 e. (let* ((serv 2fb0: 65 72 2d 69 6e 66 6f 20 28 6c 65 74 20 6c 6f 6f er-info (let loo 2fc0: 70 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 p (). 2fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le 2fe0: 74 20 28 28 73 64 61 74 20 23 66 29 29 0a 20 20 t ((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 20 28 6d 75 74 65 78 2d 6c (mutex-l 3010: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat- 3020: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 mutex*). 3030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3040: 20 20 28 73 65 74 21 20 73 64 61 74 20 2a 72 75 (set! sdat *ru 3050: 6e 72 65 6d 6f 74 65 2a 29 0a 20 20 20 20 20 20 nremote*). 3060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3070: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc 3080: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu 3090: 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 tex*). 30a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30b0: 28 69 66 20 73 64 61 74 20 73 64 61 74 0a 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 20 28 62 65 67 (beg 30e0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in. 30f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3100: 20 20 20 28 73 6c 65 65 70 20 34 29 0a 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 20 28 6c 6f (lo 3130: 6f 70 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 op)))))). 3140: 20 20 28 69 66 61 63 65 20 20 20 20 20 20 20 28 (iface ( 3150: 63 61 72 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 car server-info) 3160: 29 0a 20 20 20 20 20 20 20 20 20 28 70 6f 72 74 ). (port 3170: 20 20 20 20 20 20 20 20 28 63 61 64 72 20 73 65 (cadr se 3180: 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 20 20 rver-info)). 3190: 20 20 20 20 20 28 6c 61 73 74 2d 61 63 63 65 73 (last-acces 31a0: 73 20 30 29 0a 09 20 28 74 64 62 20 20 20 20 20 s 0).. (tdb 31b0: 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d (tasks:open- 31c0: 64 62 29 29 0a 09 20 28 73 70 69 64 20 20 20 20 db)).. (spid 31d0: 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 (tasks:serve 31e0: 72 2d 67 65 74 2d 73 65 72 76 65 72 2d 69 64 20 r-get-server-id 31f0: 74 64 62 20 23 66 20 69 66 61 63 65 20 70 6f 72 tdb #f iface por 3200: 74 20 23 66 29 29 29 0a 20 20 20 20 28 70 72 69 t #f))). (pri 3210: 6e 74 20 22 4b 65 65 70 2d 72 75 6e 6e 69 6e 67 nt "Keep-running 3220: 20 67 6f 74 20 73 65 72 76 65 72 20 70 69 64 20 got server pid 3230: 22 20 73 70 69 64 20 22 2c 20 75 73 69 6e 67 20 " spid ", using 3240: 69 66 61 63 65 20 22 20 69 66 61 63 65 20 22 20 iface " iface " 3250: 61 6e 64 20 70 6f 72 74 20 22 20 70 6f 72 74 29 and port " port) 3260: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop ( 3270: 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 (count 0)). 3280: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep! 3290: 34 29 20 3b 3b 20 6e 6f 20 6e 65 65 64 20 74 6f 4) ;; no need to 32a0: 20 64 6f 20 74 68 69 73 20 76 65 72 79 20 6f 66 do this very of 32b0: 74 65 6e 0a 20 20 20 20 20 20 3b 3b 20 4e 42 2f ten. ;; NB/ 32c0: 2f 20 73 79 6e 63 20 63 75 72 72 65 6e 74 6c 79 / sync currently 32d0: 20 64 6f 65 73 20 4e 4f 54 20 72 65 74 75 72 6e does NOT return 32e0: 20 71 75 65 75 65 2d 6c 65 6e 67 74 68 0a 20 20 queue-length. 32f0: 20 20 20 20 28 6c 65 74 20 28 29 20 3b 3b 20 28 (let () ;; ( 3300: 71 75 65 75 65 2d 6c 65 6e 20 28 63 64 62 3a 63 queue-len (cdb:c 3310: 6c 69 65 6e 74 2d 63 61 6c 6c 20 73 65 72 76 65 lient-call serve 3320: 72 2d 69 6e 66 6f 20 27 73 79 6e 63 20 23 74 20 r-info 'sync #t 3330: 31 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 70 1))). ;; (p 3340: 72 69 6e 74 20 22 53 65 72 76 65 72 20 72 75 6e rint "Server run 3350: 6e 69 6e 67 2c 20 63 6f 75 6e 74 20 69 73 20 22 ning, count is " 3360: 20 63 6f 75 6e 74 29 0a 20 20 20 20 20 20 20 20 count). 3370: 28 69 66 20 28 3c 20 63 6f 75 6e 74 20 31 29 20 (if (< count 1) 3380: 3b 3b 20 33 78 33 20 3d 20 39 20 73 65 63 73 20 ;; 3x3 = 9 secs 3390: 61 70 72 6f 78 0a 20 20 20 20 20 20 20 20 20 20 aprox. 33a0: 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 (loop (+ count 33b0: 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 0a 20 1))). . 33c0: 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 ;; NOTE: 33d0: 47 65 74 20 72 69 64 20 6f 66 20 74 68 69 73 20 Get rid of this 33e0: 6d 65 63 68 61 6e 69 73 6d 21 20 49 74 20 72 65 mechanism! It re 33f0: 61 6c 6c 79 20 69 73 20 6e 6f 74 20 6e 65 65 64 ally is not need 3400: 65 64 2e 2e 2e 0a 20 20 20 20 20 20 20 20 28 74 ed.... (t 3410: 61 73 6b 73 3a 73 65 72 76 65 72 2d 75 70 64 61 asks:server-upda 3420: 74 65 2d 68 65 61 72 74 62 65 61 74 20 74 64 62 te-heartbeat tdb 3430: 20 73 70 69 64 29 0a 20 20 20 20 20 20 0a 20 20 spid). . 3440: 20 20 20 20 20 20 3b 3b 20 28 69 66 20 3b 3b 20 ;; (if ;; 3450: 28 6f 72 20 28 3e 20 6e 75 6d 72 75 6e 6e 69 6e (or (> numrunnin 3460: 67 20 30 29 20 3b 3b 20 73 74 61 79 20 61 6c 69 g 0) ;; stay ali 3470: 76 65 20 66 6f 72 20 74 77 6f 20 64 61 79 73 20 ve for two days 3480: 61 66 74 65 72 20 6c 61 73 74 20 61 63 63 65 73 after last acces 3490: 73 0a 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 s. (mutex 34a0: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea 34b0: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 t-mutex*). 34c0: 20 20 28 73 65 74 21 20 6c 61 73 74 2d 61 63 63 (set! last-acc 34d0: 65 73 73 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 ess *last-db-acc 34e0: 65 73 73 2a 29 0a 20 20 20 20 20 20 20 20 28 6d ess*). (m 34f0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 utex-unlock! *he 3500: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*). 3510: 20 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 (if (> ( 3520: 2b 20 6c 61 73 74 2d 61 63 63 65 73 73 0a 20 20 + last-access. 3530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3540: 3b 3b 20 28 2a 20 35 30 20 36 30 20 36 30 29 20 ;; (* 50 60 60) 3550: 20 20 20 3b 3b 20 34 38 20 68 72 73 0a 20 20 20 ;; 48 hrs. 3560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ; 3570: 3b 20 36 30 20 20 20 20 20 20 20 20 20 20 20 20 ; 60 3580: 20 20 3b 3b 20 6f 6e 65 20 6d 69 6e 75 74 65 0a ;; one minute. 3590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 35a0: 20 20 3b 3b 20 28 2a 20 36 30 20 36 30 29 20 20 ;; (* 60 60) 35b0: 20 20 20 20 20 3b 3b 20 6f 6e 65 20 68 6f 75 72 ;; one hour 35c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 35d0: 20 20 20 28 2a 20 34 35 20 36 30 29 20 20 20 20 (* 45 60) 35e0: 20 20 20 20 20 20 3b 3b 20 34 35 20 6d 69 6e 75 ;; 45 minu 35f0: 74 65 73 2c 20 75 6e 74 69 6c 20 74 68 65 20 64 tes, until the d 3600: 62 20 64 65 6c 65 74 69 6f 6e 20 62 75 67 20 69 b deletion bug i 3610: 73 20 66 69 78 65 64 2e 0a 20 20 20 20 20 20 20 s fixed.. 3620: 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 ). 3630: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 (cur 3640: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 rent-seconds)). 3650: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi 3660: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n. 3670: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf 3680: 6f 20 32 20 22 53 65 72 76 65 72 20 63 6f 6e 74 o 2 "Server cont 3690: 69 6e 75 69 6e 67 2c 20 73 65 63 6f 6e 64 73 20 inuing, seconds 36a0: 73 69 6e 63 65 20 6c 61 73 74 20 64 62 20 61 63 since last db ac 36b0: 63 65 73 73 3a 20 22 20 28 2d 20 28 63 75 72 72 cess: " (- (curr 36c0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 ent-seconds) las 36d0: 74 2d 61 63 63 65 73 73 29 29 0a 20 20 20 20 20 t-access)). 36e0: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 30 (loop 0 36f0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). ( 3700: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin. 3710: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print 3720: 2d 69 6e 66 6f 20 30 20 22 53 74 61 72 74 69 6e -info 0 "Startin 3730: 67 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 74 68 g to shutdown th 3740: 65 20 73 65 72 76 65 72 2e 22 29 0a 20 20 20 20 e server."). 3750: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 65 65 ;; nee 3760: 64 20 74 6f 20 64 65 6c 65 74 65 20 6f 6e 6c 79 d to delete only 3770: 20 2a 6d 79 2a 20 73 65 72 76 65 72 20 65 6e 74 *my* server ent 3780: 72 79 20 28 66 75 74 75 72 65 20 75 73 65 29 0a ry (future use). 3790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s 37a0: 65 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 et! *time-to-exi 37b0: 74 2a 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 t* #t). 37c0: 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 (tasks:serv 37d0: 65 72 2d 64 65 72 65 67 69 73 74 65 72 2d 73 65 er-deregister-se 37e0: 6c 66 20 74 64 62 20 28 67 65 74 2d 68 6f 73 74 lf tdb (get-host 37f0: 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 -name)). 3800: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl 3810: 65 65 70 21 20 31 29 0a 20 20 20 20 20 20 20 20 eep! 1). 3820: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri 3830: 6e 74 2d 69 6e 66 6f 20 30 20 22 4d 61 78 20 63 nt-info 0 "Max c 3840: 61 63 68 65 64 20 71 75 65 72 69 65 73 20 77 61 ached queries wa 3850: 73 20 22 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 s " *max-cache-s 3860: 69 7a 65 2a 29 0a 20 20 20 20 20 20 20 20 20 20 ize*). 3870: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print 3880: 2d 69 6e 66 6f 20 30 20 22 53 65 72 76 65 72 20 -info 0 "Server 3890: 73 68 75 74 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 shutdown complet 38a0: 65 2e 20 45 78 69 74 69 6e 67 22 29 0a 20 20 20 e. Exiting"). 38b0: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 (exit 38c0: 29 29 29 29 29 29 29 0a 0a 3b 3b 20 61 6c 6c 20 )))))))..;; all 38d0: 72 6f 75 74 65 73 20 74 68 6f 75 67 68 20 68 65 routes though he 38e0: 72 65 20 65 6e 64 20 69 6e 20 65 78 69 74 20 2e re end in exit . 38f0: 2e 2e 0a 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d ...(define (zmq- 3900: 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 transport:launch 3910: 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 6f ). (if (not *to 3920: 70 70 61 74 68 2a 29 0a 20 20 20 20 20 20 28 69 ppath*). (i 3930: 66 20 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f f (not (setup-fo 3940: 72 2d 72 75 6e 29 29 0a 09 20 20 28 62 65 67 69 r-run)).. (begi 3950: 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 n.. (debug:pr 3960: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 63 61 int 0 "ERROR: ca 3970: 6e 6e 6f 74 20 66 69 6e 64 20 6d 65 67 61 74 65 nnot find megate 3980: 73 74 2e 63 6f 6e 66 69 67 2c 20 65 78 69 74 69 st.config, exiti 3990: 6e 67 22 29 0a 09 20 20 20 20 28 65 78 69 74 29 ng").. (exit) 39a0: 29 29 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 ))). (debug:pri 39b0: 6e 74 2d 69 6e 66 6f 20 32 20 22 53 74 61 72 74 nt-info 2 "Start 39c0: 69 6e 67 20 7a 6d 71 20 73 65 72 76 65 72 22 29 ing zmq server") 39d0: 0a 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a . (if *toppath* 39e0: 20 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 3b . (let* (; 39f0: 3b 20 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 ; (th1 (make-thr 3a00: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 ead (lambda ().. 3a10: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 09 20 20 ;; . 3a20: 20 20 20 20 20 28 6c 65 74 20 28 28 73 65 72 76 (let ((serv 3a30: 65 72 2d 69 6e 66 6f 20 23 66 29 29 0a 09 20 20 er-info #f)).. 3a40: 20 20 20 3b 3b 20 20 20 20 20 20 09 09 20 3b 3b ;; .. ;; 3a50: 20 77 61 69 74 20 66 6f 72 20 74 68 65 20 73 65 wait for the se 3a60: 72 76 65 72 20 74 6f 20 62 65 20 6f 6e 6c 69 6e rver to be onlin 3a70: 65 20 61 6e 64 20 61 76 61 69 6c 61 62 6c 65 0a e and available. 3a80: 09 20 20 20 20 20 3b 3b 20 20 20 20 20 20 09 09 . ;; .. 3a90: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 09 20 (let loop ().. 3aa0: 20 20 20 20 3b 3b 09 09 09 20 20 20 28 64 65 62 ;;... (deb 3ab0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2 3ac0: 22 57 61 69 74 69 6e 67 20 66 6f 72 20 74 68 65 "Waiting for the 3ad0: 20 73 65 72 76 65 72 20 74 6f 20 63 6f 6d 65 20 server to come 3ae0: 6f 6e 6c 69 6e 65 20 62 65 66 6f 72 65 20 73 74 online before st 3af0: 61 72 74 69 6e 67 20 68 65 61 72 74 62 65 61 74 arting heartbeat 3b00: 22 29 0a 09 20 20 20 20 20 3b 3b 20 20 20 20 20 ").. ;; 3b10: 20 09 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c .. (thread-sl 3b20: 65 65 70 21 20 32 29 0a 09 20 20 20 20 20 3b 3b eep! 2).. ;; 3b30: 20 20 20 20 20 20 09 09 20 20 20 28 6d 75 74 65 .. (mute 3b40: 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 x-lock! *heartbe 3b50: 61 74 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 at-mutex*).. 3b60: 20 3b 3b 20 20 20 20 20 20 09 09 20 20 20 28 73 ;; .. (s 3b70: 65 74 21 20 73 65 72 76 65 72 2d 69 6e 66 6f 20 et! server-info 3b80: 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 29 0a *server-info* ). 3b90: 09 20 20 20 20 20 3b 3b 20 20 20 20 20 20 09 09 . ;; .. 3ba0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock 3bb0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut 3bc0: 65 78 2a 29 0a 09 20 20 20 20 20 3b 3b 20 20 20 ex*).. ;; 3bd0: 20 20 20 09 09 20 20 20 28 69 66 20 28 6e 6f 74 .. (if (not 3be0: 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 28 6c 6f server-info)(lo 3bf0: 6f 70 29 29 29 0a 09 20 20 20 20 20 3b 3b 09 09 op))).. ;;.. 3c00: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 . (debug:print 2 3c10: 20 22 53 65 72 76 65 72 20 61 6c 69 76 65 2c 20 "Server alive, 3c20: 73 74 61 72 74 69 6e 67 20 73 65 6c 66 2d 70 69 starting self-pi 3c30: 6e 67 22 29 0a 09 20 20 20 20 20 3b 3b 20 20 20 ng").. ;; 3c40: 20 20 20 09 09 20 28 7a 6d 71 2d 74 72 61 6e 73 .. (zmq-trans 3c50: 70 6f 72 74 3a 73 65 6c 66 2d 70 69 6e 67 20 73 port:self-ping s 3c60: 65 72 76 65 72 2d 69 6e 66 6f 29 0a 09 20 20 20 erver-info).. 3c70: 20 20 3b 3b 20 20 20 20 20 20 09 09 20 29 29 0a ;; .. )). 3c80: 09 20 20 20 20 20 3b 3b 20 20 20 20 20 20 09 20 . ;; . 3c90: 20 20 20 20 22 53 65 6c 66 20 70 69 6e 67 22 29 "Self ping") 3ca0: 29 0a 09 20 20 20 20 20 28 74 68 32 20 28 6d 61 ).. (th2 (ma 3cb0: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd 3cc0: 61 20 28 29 0a 09 09 09 09 20 28 7a 6d 71 2d 74 a ()..... (zmq-t 3cd0: 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 0a 09 09 ransport:run ... 3ce0: 09 09 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 .. (if (args:ge 3cf0: 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server") 3d00: 0a 09 09 09 09 20 20 20 20 20 20 28 61 72 67 73 ..... (args 3d10: 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 :get-arg "-serve 3d20: 72 22 29 0a 09 09 09 09 20 20 20 20 20 20 22 2d r")..... "- 3d30: 22 29 29 29 20 22 53 65 72 76 65 72 20 72 75 6e "))) "Server run 3d40: 22 29 29 0a 09 20 20 20 20 20 3b 3b 20 28 74 68 ")).. ;; (th 3d50: 33 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 3 (make-thread ( 3d60: 6c 61 6d 62 64 61 20 28 29 28 7a 6d 71 2d 74 72 lambda ()(zmq-tr 3d70: 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e ansport:keep-run 3d80: 6e 69 6e 67 29 29 20 22 4b 65 65 70 20 72 75 6e ning)) "Keep run 3d90: 6e 69 6e 67 22 29 29 0a 09 20 20 20 20 20 29 0a ning")).. ). 3da0: 09 28 73 65 74 21 20 2a 63 6c 69 65 6e 74 2d 6e .(set! *client-n 3db0: 6f 6e 2d 62 6c 6f 63 6b 69 6e 67 2d 6d 6f 64 65 on-blocking-mode 3dc0: 2a 20 23 74 29 0a 09 3b 3b 20 28 74 68 72 65 61 * #t)..;; (threa 3dd0: 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 09 28 d-start! th1)..( 3de0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th 3df0: 32 29 0a 09 3b 3b 20 28 74 68 72 65 61 64 2d 73 2)..;; (thread-s 3e00: 74 61 72 74 21 20 74 68 33 29 0a 09 28 73 65 74 tart! th3)..(set 3e10: 21 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a ! *didsomething* 3e20: 20 23 74 29 0a 09 3b 3b 20 28 74 68 72 65 61 64 #t)..;; (thread 3e30: 2d 6a 6f 69 6e 21 20 74 68 33 29 0a 09 28 74 68 -join! th3)..(th 3e40: 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 0a read-join! th2). 3e50: 09 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a .). (debug: 3e60: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR: 3e70: 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 20 Failed to setup 3e80: 66 6f 72 20 6d 65 67 61 74 65 73 74 22 29 29 29 for megatest"))) 3e90: 0a 0a 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 ..(define (zmq-t 3ea0: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client- 3eb0: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 signal-handler s 3ec0: 69 67 6e 75 6d 29 0a 20 20 28 68 61 6e 64 6c 65 ignum). (handle 3ed0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 -exceptions. e 3ee0: 78 6e 0a 20 20 20 28 64 65 62 75 67 3a 70 72 69 xn. (debug:pri 3ef0: 6e 74 20 22 20 2e 2e 2e 20 65 78 69 74 69 6e 67 nt " ... exiting 3f00: 20 2e 2e 2e 22 29 0a 20 20 20 28 6c 65 74 20 28 ..."). (let ( 3f10: 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th1 (make-threa 3f20: 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 d (lambda ().... 3f30: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 2a 72 (if (not *r 3f40: 65 63 65 69 76 65 64 2d 72 65 73 70 6f 6e 73 65 eceived-response 3f50: 2a 29 0a 09 09 09 09 20 28 72 65 63 65 69 76 65 *)..... (receive 3f60: 2d 6d 65 73 73 61 67 65 2a 20 2a 72 75 6e 72 65 -message* *runre 3f70: 6d 6f 74 65 2a 29 29 29 20 3b 3b 20 66 6c 75 73 mote*))) ;; flus 3f80: 68 20 6f 75 74 20 6c 61 73 74 20 63 61 6c 6c 20 h out last call 3f90: 69 66 20 61 70 70 6c 69 63 61 62 6c 65 0a 09 09 if applicable... 3fa0: 09 20 20 20 22 65 61 74 20 72 65 73 70 6f 6e 73 . "eat respons 3fb0: 65 22 29 29 0a 09 20 28 74 68 32 20 28 6d 61 6b e")).. (th2 (mak 3fc0: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda 3fd0: 20 28 29 0a 09 09 09 20 20 20 20 20 28 64 65 62 ().... (deb 3fe0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO 3ff0: 52 3a 20 52 65 63 65 69 76 65 64 20 5e 43 2c 20 R: Received ^C, 4000: 61 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e attempting clean 4010: 20 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 exit. Please be 4020: 20 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 patient and wai 4030: 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 20 t a few seconds 4040: 62 65 66 6f 72 65 20 68 69 74 74 69 6e 67 20 5e before hitting ^ 4050: 43 20 61 67 61 69 6e 2e 22 29 0a 09 09 09 20 20 C again.").... 4060: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep 4070: 21 20 33 29 20 3b 3b 20 67 69 76 65 20 74 68 65 ! 3) ;; give the 4080: 20 66 6c 75 73 68 20 74 68 72 65 65 20 73 65 63 flush three sec 4090: 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 73 20 onds to do it's 40a0: 73 74 75 66 66 0a 09 09 09 20 20 20 20 20 28 64 stuff.... (d 40b0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 20 20 ebug:print 0 " 40c0: 20 20 20 20 20 44 6f 6e 65 2e 22 29 0a 09 09 09 Done.").... 40d0: 20 20 20 20 20 28 65 78 69 74 20 34 29 29 0a 09 (exit 4)).. 40e0: 09 09 20 20 20 22 65 78 69 74 20 6f 6e 20 5e 43 .. "exit on ^C 40f0: 20 74 69 6d 65 72 22 29 29 29 0a 20 20 20 20 20 timer"))). 4100: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t 4110: 68 32 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 h2). (thread 4120: 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 20 -start! th1). 4130: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join! 4140: 74 68 32 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 th2))))..(define 4150: 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a (zmq-transport: 4160: 63 6c 69 65 6e 74 2d 6c 61 75 6e 63 68 29 0a 20 client-launch). 4170: 20 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e (set-signal-han 4180: 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 69 6e 74 dler! signal/int 4190: 20 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 zmq-transport:c 41a0: 6c 69 65 6e 74 2d 73 69 67 6e 61 6c 2d 68 61 6e lient-signal-han 41b0: 64 6c 65 72 29 0a 20 20 20 28 69 66 20 28 7a 6d dler). (if (zm 41c0: 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 q-transport:clie 41d0: 6e 74 2d 73 65 74 75 70 29 0a 20 20 20 20 20 20 nt-setup). 41e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in 41f0: 66 6f 20 32 20 22 63 6f 6e 6e 65 63 74 65 64 20 fo 2 "connected 4200: 61 73 20 63 6c 69 65 6e 74 22 29 0a 20 20 20 20 as client"). 4210: 20 20 20 28 62 65 67 69 6e 0a 09 20 28 64 65 62 (begin.. (deb 4220: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO 4230: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 63 6f 6e R: Failed to con 4240: 6e 65 63 74 20 61 73 20 63 6c 69 65 6e 74 22 29 nect as client") 4250: 0a 09 20 28 65 78 69 74 29 29 29 29 0a 0a 3b 3b .. (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 3d 0a 3b 3b 20 44 65 66 75 6e 63 ======.;; Defunc 42b0: 74 20 66 75 6e 63 74 69 6f 6e 73 0a 3b 3b 3d 3d t 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 3d 0a 0a 3b 3b 20 70 69 6e 67 20 61 20 ====..;; ping a 4310: 73 65 72 76 65 72 20 61 6e 64 20 72 65 74 75 72 server and retur 4320: 6e 20 6e 75 6d 62 65 72 20 6f 66 20 63 6c 69 65 n number of clie 4330: 6e 74 73 20 6f 72 20 23 66 20 28 69 66 20 6e 6f nts or #f (if no 4340: 20 72 65 73 70 6f 6e 73 65 29 0a 3b 3b 20 4e 4f response).;; NO 4350: 54 20 49 4e 20 55 53 45 21 0a 28 64 65 66 69 6e T IN USE!.(defin 4360: 65 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 e (zmq-transport 4370: 3a 70 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 20 :ping host port 4380: 23 21 6b 65 79 20 28 73 65 63 73 20 31 30 29 28 #!key (secs 10)( 4390: 72 65 74 75 72 6e 2d 73 6f 63 6b 65 74 20 23 66 return-socket #f 43a0: 29 29 0a 20 20 28 63 64 62 3a 75 73 65 2d 6e 6f )). (cdb:use-no 43b0: 6e 2d 62 6c 6f 63 6b 69 6e 67 2d 6d 6f 64 65 0a n-blocking-mode. 43c0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda (). 43d0: 20 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 23 (let* ((res # 43e0: 66 29 0a 09 20 20 20 20 28 74 68 31 20 28 6d 61 f).. (th1 (ma 43f0: 6b 65 2d 74 68 72 65 61 64 0a 09 09 20 20 28 6c ke-thread... (l 4400: 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 28 ambda ()... ( 4410: 6c 65 74 2a 20 28 28 7a 6d 71 2d 63 6f 6e 74 65 let* ((zmq-conte 4420: 78 74 20 28 6d 61 6b 65 2d 63 6f 6e 74 65 78 74 xt (make-context 4430: 20 31 29 29 0a 09 09 09 20 20 20 28 7a 6d 71 2d 1)).... (zmq- 4440: 73 6f 63 6b 65 74 20 20 28 7a 6d 71 2d 74 72 61 socket (zmq-tra 4450: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f nsport:client-co 4460: 6e 6e 65 63 74 20 68 6f 73 74 20 70 6f 72 74 20 nnect host port 4470: 63 6f 6e 74 65 78 74 3a 20 7a 6d 71 2d 63 6f 6e context: zmq-con 4480: 74 65 78 74 29 29 29 0a 09 09 20 20 20 20 20 20 text)))... 4490: 28 69 66 20 7a 6d 71 2d 73 6f 63 6b 65 74 0a 09 (if zmq-socket.. 44a0: 09 09 20 20 28 69 66 20 28 7a 6d 71 2d 74 72 61 .. (if (zmq-tra 44b0: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 6c 6f nsport:client-lo 44c0: 67 69 6e 20 7a 6d 71 2d 73 6f 63 6b 65 74 29 0a gin zmq-socket). 44d0: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let (( 44e0: 6e 75 6d 63 6c 69 65 6e 74 73 20 28 63 64 62 3a numclients (cdb: 44f0: 6e 75 6d 2d 63 6c 69 65 6e 74 73 20 7a 6d 71 2d num-clients zmq- 4500: 73 6f 63 6b 65 74 29 29 29 0a 09 09 09 09 28 69 socket))).....(i 4510: 66 20 28 6e 6f 74 20 72 65 74 75 72 6e 2d 73 6f f (not return-so 4520: 63 6b 65 74 29 0a 09 09 09 09 20 20 20 20 28 62 cket)..... (b 4530: 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 28 egin..... ( 4540: 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c zmq-transport:cl 4550: 69 65 6e 74 2d 6c 6f 67 6f 75 74 20 7a 6d 71 2d ient-logout zmq- 4560: 73 6f 63 6b 65 74 29 0a 09 09 09 09 20 20 20 20 socket)..... 4570: 20 20 28 63 6c 6f 73 65 2d 73 6f 63 6b 65 74 20 (close-socket 4580: 20 7a 6d 71 2d 73 6f 63 6b 65 74 29 29 29 0a 09 zmq-socket))).. 4590: 09 09 09 28 73 65 74 21 20 72 65 73 20 28 6c 69 ...(set! res (li 45a0: 73 74 20 23 74 20 6e 75 6d 63 6c 69 65 6e 74 73 st #t numclients 45b0: 20 28 69 66 20 72 65 74 75 72 6e 2d 73 6f 63 6b (if return-sock 45c0: 65 74 20 7a 6d 71 2d 73 6f 63 6b 65 74 20 23 66 et zmq-socket #f 45d0: 29 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 )))).... (b 45e0: 65 67 69 6e 0a 09 09 09 09 3b 3b 20 28 63 6c 6f egin.....;; (clo 45f0: 73 65 2d 73 6f 63 6b 65 74 20 7a 6d 71 2d 73 6f se-socket zmq-so 4600: 63 6b 65 74 29 0a 09 09 09 09 28 73 65 74 21 20 cket).....(set! 4610: 72 65 73 20 28 6c 69 73 74 20 23 66 20 22 43 41 res (list #f "CA 4620: 4e 27 54 20 4c 4f 47 49 4e 22 20 23 66 29 29 29 N'T LOGIN" #f))) 4630: 29 0a 09 09 09 20 20 28 73 65 74 21 20 72 65 73 ).... (set! res 4640: 20 28 6c 69 73 74 20 23 66 20 22 43 41 4e 27 54 (list #f "CAN'T 4650: 20 43 4f 4e 4e 45 43 54 22 20 23 66 29 29 29 29 CONNECT" #f)))) 4660: 29 0a 09 09 20 20 22 50 69 6e 67 3a 20 74 68 31 )... "Ping: th1 4670: 22 29 29 0a 09 20 20 20 20 28 74 68 32 20 28 6d ")).. (th2 (m 4680: 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 20 20 28 ake-thread... ( 4690: 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 lambda ()... 46a0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e (let loop ((coun 46b0: 74 20 31 29 29 0a 09 09 20 20 20 20 20 20 28 64 t 1))... (d 46c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info 46d0: 31 20 22 50 69 6e 67 20 22 20 63 6f 75 6e 74 20 1 "Ping " count 46e0: 22 20 73 65 72 76 65 72 20 6f 6e 20 22 20 68 6f " server on " ho 46f0: 73 74 20 22 20 61 74 20 70 6f 72 74 20 22 20 70 st " at port " p 4700: 6f 72 74 29 0a 09 09 20 20 20 20 20 20 28 74 68 ort)... (th 4710: 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 read-sleep! 2).. 4720: 09 20 20 20 20 20 20 28 69 66 20 28 3c 20 63 6f . (if (< co 4730: 75 6e 74 20 28 2f 20 73 65 63 73 20 32 29 29 0a unt (/ secs 2)). 4740: 09 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f ... (loop (+ co 4750: 75 6e 74 20 31 29 29 29 29 0a 09 09 20 20 20 20 unt 1))))... 4760: 3b 3b 20 28 74 68 72 65 61 64 2d 74 65 72 6d 69 ;; (thread-termi 4770: 6e 61 74 65 21 20 74 68 31 29 0a 09 09 20 20 20 nate! th1)... 4780: 20 28 73 65 74 21 20 72 65 73 20 28 6c 69 73 74 (set! res (list 4790: 20 23 66 20 22 54 49 4d 45 44 20 4f 55 54 22 20 #f "TIMED OUT" 47a0: 23 66 29 29 29 0a 09 09 20 20 22 50 69 6e 67 3a #f)))... "Ping: 47b0: 20 74 68 32 22 29 29 29 0a 20 20 20 20 20 20 20 th2"))). 47c0: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t 47d0: 68 32 29 0a 20 20 20 20 20 20 20 28 74 68 72 65 h2). (thre 47e0: 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 ad-start! th1). 47f0: 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 (handle-ex 4800: 63 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a 09 28 ceptions..exn..( 4810: 73 65 74 21 20 72 65 73 20 28 6c 69 73 74 20 23 set! res (list # 4820: 66 20 22 54 49 4d 45 44 20 4f 55 54 22 20 23 66 f "TIMED OUT" #f 4830: 29 29 0a 09 28 74 68 72 65 61 64 2d 6a 6f 69 6e ))..(thread-join 4840: 21 20 74 68 31 20 73 65 63 73 29 29 0a 20 20 20 ! th1 secs)). 4850: 20 20 20 20 72 65 73 29 29 29 29 0a 0a 3b 3b 20 res))))..;; 4860: 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 61 (define (zmq-tra 4870: 6e 73 70 6f 72 74 3a 73 65 6c 66 2d 70 69 6e 67 nsport:self-ping 4880: 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 0a 3b 3b server-info).;; 4890: 20 20 20 3b 3b 20 73 65 72 76 65 72 2d 69 6e 66 ;; server-inf 48a0: 6f 3a 20 73 65 72 76 65 72 2d 69 64 20 69 6e 74 o: server-id int 48b0: 65 72 66 61 63 65 20 70 75 6c 6c 70 6f 72 74 20 erface pullport 48c0: 70 75 62 70 6f 72 74 0a 3b 3b 20 20 20 28 6c 65 pubport.;; (le 48d0: 74 20 28 28 69 66 61 63 65 20 20 20 20 28 6c 69 t ((iface (li 48e0: 73 74 2d 72 65 66 20 73 65 72 76 65 72 2d 69 6e st-ref server-in 48f0: 66 6f 20 31 29 29 0a 3b 3b 20 09 28 70 75 6c 6c fo 1)).;; .(pull 4900: 70 6f 72 74 20 28 6c 69 73 74 2d 72 65 66 20 73 port (list-ref s 4910: 65 72 76 65 72 2d 69 6e 66 6f 20 32 29 29 0a 3b erver-info 2)).; 4920: 3b 20 09 28 70 75 62 70 6f 72 74 20 20 28 6c 69 ; .(pubport (li 4930: 73 74 2d 72 65 66 20 73 65 72 76 65 72 2d 69 6e st-ref server-in 4940: 66 6f 20 33 29 29 29 0a 3b 3b 20 20 20 20 20 28 fo 3))).;; ( 4950: 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c zmq-transport:cl 4960: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 ient-connect ifa 4970: 63 65 20 70 75 6c 6c 70 6f 72 74 20 70 75 62 70 ce pullport pubp 4980: 6f 72 74 29 0a 3b 3b 20 20 20 20 20 28 6c 65 74 ort).;; (let 4990: 20 6c 6f 6f 70 20 28 29 0a 3b 3b 20 20 20 20 20 loop ().;; 49a0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep! 49b0: 20 32 29 0a 3b 3b 20 20 20 20 20 20 20 28 63 64 2).;; (cd 49c0: 62 3a 63 6c 69 65 6e 74 2d 63 61 6c 6c 20 2a 72 b:client-call *r 49d0: 75 6e 72 65 6d 6f 74 65 2a 20 27 70 69 6e 67 20 unremote* 'ping 49e0: 23 74 29 0a 3b 3b 20 20 20 20 20 20 20 28 64 65 #t).;; (de 49f0: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 7a 6d 71 bug:print 4 "zmq 4a00: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 6c 66 2d -transport:self- 4a10: 70 69 6e 67 20 2d 20 49 27 6d 20 61 6c 69 76 65 ping - I'm alive 4a20: 20 6f 6e 20 22 20 69 66 61 63 65 20 22 3a 22 20 on " iface ":" 4a30: 70 75 6c 6c 70 6f 72 74 20 22 2f 22 20 70 75 62 pullport "/" pub 4a40: 70 6f 72 74 20 22 21 22 29 0a 3b 3b 20 20 20 20 port "!").;; 4a50: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock! 4a60: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex 4a70: 2a 29 0a 3b 3b 20 20 20 20 20 20 20 28 73 65 74 *).;; (set 4a80: 21 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 ! *server-loop-h 4a90: 65 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 72 eart-beat* (curr 4aa0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 3b 3b ent-seconds)).;; 4ab0: 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e (mutex-un 4ac0: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat 4ad0: 2d 6d 75 74 65 78 2a 29 0a 3b 3b 20 20 20 20 20 -mutex*).;; 4ae0: 20 20 28 6c 6f 6f 70 29 29 29 29 0a 20 20 20 20 (loop)))). 4af0: 0a 28 64 65 66 69 6e 65 20 28 7a 6d 71 2d 74 72 .(define (zmq-tr 4b00: 61 6e 73 70 6f 72 74 3a 72 65 70 6c 79 20 70 75 ansport:reply pu 4b10: 62 73 6f 63 6b 20 74 61 72 67 65 74 20 71 75 65 bsock target que 4b20: 72 79 2d 73 69 67 20 73 75 63 63 65 73 73 2f 66 ry-sig success/f 4b30: 61 69 6c 20 72 65 73 75 6c 74 29 0a 20 20 28 64 ail result). (d 4b40: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info 4b50: 31 31 20 22 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 11 "zmq-transpor 4b60: 74 3a 72 65 70 6c 79 20 74 61 72 67 65 74 3d 22 t:reply target=" 4b70: 20 74 61 72 67 65 74 20 22 2c 20 72 65 73 75 6c target ", resul 4b80: 74 3d 22 20 72 65 73 75 6c 74 29 0a 20 20 28 73 t=" result). (s 4b90: 65 6e 64 2d 6d 65 73 73 61 67 65 20 70 75 62 73 end-message pubs 4ba0: 6f 63 6b 20 74 61 72 67 65 74 20 73 65 6e 64 2d ock target send- 4bb0: 6d 6f 72 65 3a 20 23 74 29 0a 20 20 28 73 65 6e more: #t). (sen 4bc0: 64 2d 6d 65 73 73 61 67 65 20 70 75 62 73 6f 63 d-message pubsoc 4bd0: 6b 20 28 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e k (db:obj->strin 4be0: 67 20 28 76 65 63 74 6f 72 20 73 75 63 63 65 73 g (vector succes 4bf0: 73 2f 66 61 69 6c 20 71 75 65 72 79 2d 73 69 67 s/fail query-sig 4c00: 20 72 65 73 75 6c 74 29 29 29 29 0a 0a result))))..