Artifact
fa92993bb8f3d6b5ea36ba95653bc507c3e0e5de:
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 3b 3b 3 sqlite3:))..;;
01f0: 20 28 75 73 65 20 6e 61 6e 6f 6d 73 67 29 0a 0a (use nanomsg)..
0200: 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 6e (declare (unit n
0210: 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a msg-transport)).
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 common)).(declar
0240: 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 65 e (uses db)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 73 74 clare (uses test
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 74 61 73 6b 73 29 29 20 3b 3b 20 74 61 es tasks)) ;; ta
0280: 73 6b 73 20 61 72 65 20 77 68 65 72 65 20 73 74 sks are where st
0290: 75 66 66 20 69 73 20 6d 61 69 6e 74 61 69 6e 65 uff is maintaine
02a0: 64 20 61 62 6f 75 74 20 77 68 61 74 20 69 73 20 d about what is
02b0: 72 75 6e 6e 69 6e 67 2e 0a 28 64 65 63 6c 61 72 running..(declar
02c0: 65 20 28 75 73 65 73 20 73 65 72 76 65 72 29 29 e (uses server))
02d0: 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d ..(include "comm
02e0: 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 on_records.scm")
02f0: 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 .(include "db_re
0300: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 cords.scm")..;;
0310: 54 72 61 6e 73 69 74 69 6f 6e 20 74 6f 20 70 75 Transition to pu
0320: 62 20 2d 2d 3e 20 73 75 62 20 77 69 74 68 20 70 b --> sub with p
0330: 75 6c 6c 20 3c 2d 2d 20 70 75 73 68 0a 3b 3b 0a ull <-- push.;;.
0340: 3b 3b 20 20 20 31 2e 20 63 6c 69 65 6e 74 20 73 ;; 1. client s
0350: 65 6e 64 73 20 72 65 71 75 65 73 74 20 74 6f 20 ends request to
0360: 73 65 72 76 65 72 20 76 69 61 20 70 75 73 68 20 server via push
0370: 74 6f 20 74 68 65 20 70 75 6c 6c 20 70 6f 72 74 to the pull port
0380: 0a 3b 3b 20 20 20 32 2e 20 73 65 72 76 65 72 20 .;; 2. server
0390: 70 75 74 73 20 72 65 71 75 65 73 74 20 69 6e 20 puts request in
03a0: 71 75 65 75 65 20 6f 72 20 70 72 6f 63 65 73 73 queue or process
03b0: 65 73 20 69 6d 6d 65 64 69 61 74 65 6c 79 20 61 es immediately a
03c0: 73 20 61 70 70 72 6f 70 72 69 61 74 65 0a 3b 3b s appropriate.;;
03d0: 20 20 20 33 2e 20 73 65 72 76 65 72 20 70 75 74 3. server put
03e0: 73 20 72 65 73 70 6f 6e 73 65 73 20 66 72 6f 6d s responses from
03f0: 20 63 6f 6d 70 6c 65 74 65 64 20 72 65 71 75 65 completed reque
0400: 73 74 73 20 69 6e 74 6f 20 70 75 62 20 70 6f 72 sts into pub por
0410: 74 20 0a 3b 3b 0a 3b 3b 20 54 4f 44 4f 0a 3b 3b t .;;.;; TODO.;;
0420: 0a 3b 3b 20 44 6f 6e 65 20 54 65 73 74 65 64 0a .;; Done Tested.
0430: 3b 3b 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 31 ;; [x] [ ] 1
0440: 2e 20 41 64 64 20 63 6f 6c 75 6d 6e 73 20 70 75 . Add columns pu
0450: 6c 6c 70 6f 72 74 20 70 75 62 70 6f 72 74 20 74 llport pubport t
0460: 6f 20 73 65 72 76 65 72 73 20 74 61 62 6c 65 0a o servers table.
0470: 3b 3b 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 32 ;; [x] [ ] 2
0480: 2e 20 41 64 64 20 72 6d 20 6f 66 20 6d 6f 6e 69 . Add rm of moni
0490: 74 6f 72 2e 64 62 20 69 66 20 6f 6c 64 65 72 20 tor.db if older
04a0: 74 68 61 6e 20 31 31 2f 31 32 2f 32 30 31 32 20 than 11/12/2012
04b0: 0a 3b 3b 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 .;; [x] [ ]
04c0: 33 2e 20 41 64 64 20 63 72 65 61 74 65 20 6f 66 3. Add create of
04d0: 20 70 75 6c 6c 70 6f 72 74 20 61 6e 64 20 70 75 pullport and pu
04e0: 62 70 6f 72 74 20 77 69 74 68 20 66 69 6e 64 69 bport with findi
04f0: 6e 67 20 6f 66 20 61 76 61 69 6c 61 62 6c 65 20 ng of available
0500: 70 6f 72 74 73 0a 3b 3b 20 5b 78 5d 20 20 5b 20 ports.;; [x] [
0510: 5d 20 20 20 20 34 2e 20 41 64 64 20 63 6c 69 65 ] 4. Add clie
0520: 6e 74 20 63 6f 6d 70 6f 73 65 20 6f 66 20 72 65 nt compose of re
0530: 71 75 65 73 74 0a 3b 3b 20 5b 78 5d 20 20 5b 20 quest.;; [x] [
0540: 5d 20 20 20 20 20 20 20 20 2d 20 6e 61 6d 65 20 ] - name
0550: 6f 66 20 63 6c 69 65 6e 74 3a 20 74 65 73 74 6e of client: testn
0560: 61 6d 65 2f 69 74 65 6d 70 61 74 68 2d 74 65 73 ame/itempath-tes
0570: 74 5f 69 64 2d 68 6f 73 74 6e 61 6d 65 20 0a 3b t_id-hostname .;
0580: 3b 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 20 20 ; [x] [ ]
0590: 20 20 2d 20 6e 61 6d 65 20 6f 66 20 72 65 71 75 - name of requ
05a0: 65 73 74 3a 20 63 61 6c 6c 6e 61 6d 65 2c 20 70 est: callname, p
05b0: 61 72 61 6d 73 0a 3b 3b 20 5b 78 5d 20 20 5b 20 arams.;; [x] [
05c0: 5d 20 20 20 20 20 20 20 20 2d 20 72 65 71 75 65 ] - reque
05d0: 73 74 20 6b 65 79 3a 20 66 28 63 6c 69 65 6e 74 st key: f(client
05e0: 6e 61 6d 65 2c 20 63 61 6c 6c 6e 61 6d 65 2c 20 name, callname,
05f0: 70 61 72 61 6d 73 29 0a 3b 3b 20 5b 78 5d 20 20 params).;; [x]
0600: 5b 20 5d 20 20 20 20 35 2e 20 41 64 64 20 70 72 [ ] 5. Add pr
0610: 6f 63 65 73 73 69 6e 67 20 6f 66 20 73 75 62 73 ocessing of subs
0620: 63 72 69 70 74 69 6f 6e 20 68 69 74 73 0a 3b 3b cription hits.;;
0630: 20 5b 78 5d 20 20 5b 20 5d 20 20 20 20 20 20 20 [x] [ ]
0640: 20 2d 20 64 6f 6e 65 20 77 68 65 6e 20 67 65 74 - done when get
0650: 20 6b 65 79 20 0a 3b 3b 20 5b 78 5d 20 20 5b 20 key .;; [x] [
0660: 5d 20 20 20 20 20 20 20 20 2d 20 72 65 74 75 72 ] - retur
0670: 6e 20 72 65 73 75 6c 74 73 0a 3b 3b 20 5b 78 5d n results.;; [x]
0680: 20 20 5b 20 5d 20 20 20 20 36 2e 20 41 64 64 20 [ ] 6. Add
0690: 74 69 6d 65 6f 75 74 20 70 72 6f 63 65 73 73 69 timeout processi
06a0: 6e 67 0a 3b 3b 20 5b 78 5d 20 20 5b 20 5d 20 20 ng.;; [x] [ ]
06b0: 20 20 20 20 20 20 2d 20 61 66 74 65 72 20 36 30 - after 60
06c0: 20 73 65 63 6f 6e 64 73 0a 3b 3b 20 5b 20 5d 20 seconds.;; [ ]
06d0: 20 5b 20 5d 20 20 20 20 20 20 20 20 20 20 20 20 [ ]
06e0: 69 2e 20 63 68 65 63 6b 20 73 65 72 76 65 72 20 i. check server
06f0: 61 6c 69 76 65 2c 20 63 6f 6e 6e 65 63 74 20 74 alive, connect t
0700: 6f 20 6e 65 77 20 69 66 20 6e 65 63 65 73 73 61 o new if necessa
0710: 72 79 0a 3b 3b 20 5b 20 5d 20 20 5b 20 5d 20 20 ry.;; [ ] [ ]
0720: 20 20 20 20 20 20 20 20 20 69 69 2e 20 72 65 73 ii. res
0730: 65 6e 64 20 72 65 71 75 65 73 74 0a 3b 3b 20 5b end request.;; [
0740: 20 5d 20 20 5b 20 5d 20 20 20 20 37 2e 20 54 75 ] [ ] 7. Tu
0750: 72 6e 20 73 65 6c 66 20 70 69 6e 67 20 62 61 63 rn self ping bac
0760: 6b 20 6f 6e 0a 0a 28 64 65 66 69 6e 65 20 28 6e k on..(define (n
0770: 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 msg-transport:ma
0780: 6b 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 68 6f ke-server-url ho
0790: 73 74 70 6f 72 74 20 23 21 6b 65 79 20 28 62 69 stport #!key (bi
07a0: 6e 64 61 6c 6c 20 23 66 29 29 0a 20 20 28 69 66 ndall #f)). (if
07b0: 20 28 6e 6f 74 20 68 6f 73 74 70 6f 72 74 29 0a (not hostport).
07c0: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
07d0: 63 6f 6e 63 20 22 74 63 70 3a 2f 2f 22 20 28 69 conc "tcp://" (i
07e0: 66 20 62 69 6e 64 61 6c 6c 20 22 2a 22 20 28 63 f bindall "*" (c
07f0: 61 72 20 68 6f 73 74 70 6f 72 74 29 29 20 22 3a ar hostport)) ":
0800: 22 20 28 63 61 64 72 20 68 6f 73 74 70 6f 72 74 " (cadr hostport
0810: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 ))))..(define *s
0820: 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 erver-loop-heart
0830: 2d 62 65 61 74 2a 20 28 63 75 72 72 65 6e 74 2d -beat* (current-
0840: 73 65 63 6f 6e 64 73 29 29 0a 28 64 65 66 69 6e seconds)).(defin
0850: 65 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 e *heartbeat-mut
0860: 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 ex* (make-mutex)
0870: 29 0a 0a 3b 3b 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 3d ================
0890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 53 ===========.;; S
08c0: 20 45 20 52 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d E R V E R.;;===
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 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0910: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6e 6d ===..(define (nm
0920: 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e sg-transport:run
0930: 20 64 62 73 74 72 75 63 74 20 61 72 65 61 2d 64 dbstruct area-d
0940: 61 74 20 68 6f 73 74 6e 20 72 75 6e 2d 69 64 20 at hostn run-id
0950: 73 65 72 76 65 72 2d 69 64 20 23 21 6b 65 79 20 server-id #!key
0960: 28 72 65 74 72 79 6e 75 6d 20 31 30 30 30 29 29 (retrynum 1000))
0970: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
0980: 32 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 2 "Attempting to
0990: 20 73 74 61 72 74 20 74 68 65 20 73 65 72 76 65 start the serve
09a0: 72 20 2e 2e 2e 22 29 0a 20 20 28 6c 65 74 2a 20 r ..."). (let*
09b0: 28 28 73 74 61 72 74 2d 70 6f 72 74 20 20 20 20 ((start-port
09c0: 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 (portlogger:op
09d0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 en-run-close por
09e0: 74 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 tlogger:find-por
09f0: 74 20 61 72 65 61 2d 64 61 74 29 29 0a 09 20 28 t area-dat)).. (
0a00: 73 65 72 76 65 72 2d 74 68 72 65 61 64 20 20 20 server-thread
0a10: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
0a20: 6d 62 64 61 20 28 29 0a 09 09 09 09 09 20 28 6e mbda ()...... (n
0a30: 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 msg-transport:tr
0a40: 79 2d 73 74 61 72 74 2d 73 65 72 76 65 72 20 64 y-start-server d
0a50: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 73 bstruct run-id s
0a60: 74 61 72 74 2d 70 6f 72 74 20 73 65 72 76 65 72 tart-port server
0a70: 2d 69 64 29 29 0a 09 09 09 09 20 20 20 20 20 20 -id)).....
0a80: 20 22 73 65 72 76 65 72 20 74 68 72 65 61 64 22 "server thread"
0a90: 29 29 0a 09 20 28 74 64 62 64 61 74 20 20 20 20 )).. (tdbdat
0aa0: 20 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 (tasks:ope
0ab0: 6e 2d 64 62 20 61 72 65 61 2d 64 61 74 29 29 29 n-db area-dat)))
0ac0: 0a 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 . (thread-sta
0ad0: 72 74 21 20 73 65 72 76 65 72 2d 74 68 72 65 61 rt! server-threa
0ae0: 64 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d 73 d). (thread-s
0af0: 6c 65 65 70 21 20 30 2e 31 29 0a 20 20 20 20 28 leep! 0.1). (
0b00: 69 66 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f if (nmsg-transpo
0b10: 72 74 3a 70 69 6e 67 20 68 6f 73 74 6e 20 73 74 rt:ping hostn st
0b20: 61 72 74 2d 70 6f 72 74 20 74 69 6d 65 6f 75 74 art-port timeout
0b30: 3a 20 32 20 65 78 70 65 63 74 65 64 2d 6b 65 79 : 2 expected-key
0b40: 3a 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 : (current-proce
0b50: 73 73 2d 69 64 29 29 0a 09 28 6c 65 74 20 28 28 ss-id))..(let ((
0b60: 69 6e 74 65 72 66 61 63 65 20 28 69 66 20 28 65 interface (if (e
0b70: 71 75 61 6c 3f 20 68 6f 73 74 6e 20 22 2d 22 29 qual? hostn "-")
0b80: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 (get-host-name)
0b90: 68 6f 73 74 6e 29 29 29 0a 09 20 20 28 74 61 73 hostn))).. (tas
0ba0: 6b 73 3a 73 65 72 76 65 72 2d 73 65 74 2d 69 6e ks:server-set-in
0bb0: 74 65 72 66 61 63 65 2d 70 6f 72 74 20 28 64 62 terface-port (db
0bc0: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 :delay-if-busy t
0bd0: 64 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 64 dbdat) server-id
0be0: 20 69 6e 74 65 72 66 61 63 65 20 73 74 61 72 74 interface start
0bf0: 2d 70 6f 72 74 29 0a 09 20 20 28 74 61 73 6b 73 -port).. (tasks
0c00: 3a 73 65 72 76 65 72 2d 73 65 74 2d 73 74 61 74 :server-set-stat
0c10: 65 21 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d e! (db:delay-if-
0c20: 62 75 73 79 20 74 64 62 64 61 74 29 20 73 65 72 busy tdbdat) ser
0c30: 76 65 72 2d 69 64 20 22 64 62 70 72 65 70 22 29 ver-id "dbprep")
0c40: 0a 09 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 .. (set! *serve
0c50: 72 2d 69 6e 66 6f 2a 20 28 6c 69 73 74 20 68 6f r-info* (list ho
0c60: 73 74 6e 20 73 74 61 72 74 2d 70 6f 72 74 29 29 stn start-port))
0c70: 20 3b 3b 20 70 72 6f 62 61 62 6c 79 20 6e 6f 74 ;; probably not
0c80: 20 6e 65 65 64 65 64 20 61 6e 79 6d 6f 72 65 3f needed anymore?
0c90: 20 63 75 72 72 65 6e 74 6c 79 20 75 73 65 64 20 currently used
0ca0: 62 79 20 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 0a by keep-running.
0cb0: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
0cc0: 21 20 33 29 20 3b 3b 20 67 69 76 65 20 73 6f 6d ! 3) ;; give som
0cd0: 65 20 6d 61 72 67 69 6e 20 66 6f 72 20 71 75 65 e margin for que
0ce0: 72 69 65 73 20 74 6f 20 63 6f 6d 70 6c 65 74 65 ries to complete
0cf0: 20 62 65 66 6f 72 65 20 73 77 69 74 63 68 69 6e before switchin
0d00: 67 20 66 72 6f 6d 20 66 69 6c 65 20 62 61 73 65 g from file base
0d10: 64 20 61 63 63 65 73 73 20 74 6f 20 73 65 72 76 d access to serv
0d20: 65 72 20 62 61 73 65 64 20 61 63 63 65 73 73 0a er based access.
0d30: 09 20 20 3b 3b 20 28 73 65 74 21 20 2a 69 6e 6d . ;; (set! *inm
0d40: 65 6d 64 62 2a 20 20 64 62 73 74 72 75 63 74 29 emdb* dbstruct)
0d50: 0a 09 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 .. (tasks:serve
0d60: 72 2d 73 65 74 2d 73 74 61 74 65 21 20 28 64 62 r-set-state! (db
0d70: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 :delay-if-busy t
0d80: 64 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 64 dbdat) server-id
0d90: 20 22 72 75 6e 6e 69 6e 67 22 29 0a 09 20 20 28 "running").. (
0da0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 28 6d thread-start! (m
0db0: 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 20 20 ake-thread....
0dc0: 28 6c 61 6d 62 64 61 20 28 29 28 6e 6d 73 67 2d (lambda ()(nmsg-
0dd0: 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 transport:keep-r
0de0: 75 6e 6e 69 6e 67 20 73 65 72 76 65 72 2d 69 64 unning server-id
0df0: 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 run-id area-dat
0e00: 29 29 0a 09 09 09 20 20 22 6b 65 65 70 20 72 75 )).... "keep ru
0e10: 6e 6e 69 6e 67 22 29 29 0a 09 20 20 28 74 68 72 nning")).. (thr
0e20: 65 61 64 2d 6a 6f 69 6e 21 20 73 65 72 76 65 72 ead-join! server
0e30: 2d 74 68 72 65 61 64 29 29 0a 09 28 69 66 20 28 -thread))..(if (
0e40: 3e 20 72 65 74 72 79 6e 75 6d 20 30 29 0a 09 20 > retrynum 0)..
0e50: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
0e60: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
0e70: 22 57 41 52 4e 49 4e 47 3a 20 46 61 69 6c 65 64 "WARNING: Failed
0e80: 20 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f 20 73 to connect to s
0e90: 65 72 76 65 72 20 28 73 65 6c 66 29 20 6f 6e 20 erver (self) on
0ea0: 68 6f 73 74 20 22 20 68 6f 73 74 6e 20 22 3a 22 host " hostn ":"
0eb0: 20 73 74 61 72 74 2d 70 6f 72 74 20 22 2c 20 74 start-port ", t
0ec0: 72 79 69 6e 67 20 61 67 61 69 6e 2e 22 29 0a 09 rying again.")..
0ed0: 20 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 (tasks:ser
0ee0: 76 65 72 2d 64 65 6c 65 74 65 2d 72 65 63 6f 72 ver-delete-recor
0ef0: 64 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 d (db:delay-if-b
0f00: 75 73 79 20 74 64 62 64 61 74 29 20 73 65 72 76 usy tdbdat) serv
0f10: 65 72 2d 69 64 20 22 66 61 69 6c 65 64 20 74 6f er-id "failed to
0f20: 20 73 74 61 72 74 2c 20 6e 65 76 65 72 20 72 65 start, never re
0f30: 63 65 69 76 65 64 20 73 65 72 76 65 72 20 61 6c ceived server al
0f40: 69 76 65 20 73 69 67 6e 61 74 75 72 65 22 29 0a ive signature").
0f50: 09 20 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 . (portlogg
0f60: 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 er:open-run-clos
0f70: 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 e portlogger:set
0f80: 2d 66 61 69 6c 65 64 20 61 72 65 61 2d 64 61 74 -failed area-dat
0f90: 20 73 74 61 72 74 2d 70 6f 72 74 29 0a 09 20 20 start-port)..
0fa0: 20 20 20 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 (nmsg-transp
0fb0: 6f 72 74 3a 72 75 6e 20 64 62 73 74 72 75 63 74 ort:run dbstruct
0fc0: 20 61 72 65 61 2d 64 61 74 20 68 6f 73 74 6e 20 area-dat hostn
0fd0: 72 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 69 64 run-id server-id
0fe0: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )).. (begin..
0ff0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1000: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 63 6f 75 nt 0 "ERROR: cou
1010: 6c 64 20 6e 6f 74 20 66 69 6e 64 20 61 6e 20 6f ld not find an o
1020: 70 65 6e 20 70 6f 72 74 20 74 6f 20 73 74 61 72 pen port to star
1030: 74 20 73 65 72 76 65 72 20 6f 6e 2e 20 47 69 76 t server on. Giv
1040: 69 6e 67 20 75 70 22 29 0a 09 20 20 20 20 20 20 ing up")..
1050: 28 65 78 69 74 20 31 29 29 29 29 29 29 0a 0a 28 (exit 1))))))..(
1060: 64 65 66 69 6e 65 20 28 6e 6d 73 67 2d 74 72 61 define (nmsg-tra
1070: 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 nsport:try-start
1080: 2d 73 65 72 76 65 72 20 64 62 73 74 72 75 63 74 -server dbstruct
1090: 20 72 75 6e 2d 69 64 20 70 6f 72 74 6e 75 6d 20 run-id portnum
10a0: 73 65 72 76 65 72 2d 69 64 29 0a 20 20 28 6c 65 server-id). (le
10b0: 74 20 28 28 72 65 70 73 6f 63 20 28 6e 6e 2d 73 t ((repsoc (nn-s
10c0: 6f 63 6b 65 74 20 27 72 65 70 29 29 29 0a 20 20 ocket 'rep))).
10d0: 20 20 28 6e 6e 2d 62 69 6e 64 20 72 65 70 73 6f (nn-bind repso
10e0: 63 20 28 63 6f 6e 63 20 22 74 63 70 3a 2f 2f 2a c (conc "tcp://*
10f0: 3a 22 20 70 6f 72 74 6e 75 6d 29 29 0a 20 20 20 :" portnum)).
1100: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6d 73 67 (let loop ((msg
1110: 2d 69 6e 20 28 6e 6e 2d 72 65 63 76 20 72 65 70 -in (nn-recv rep
1120: 73 6f 63 29 29 29 0a 20 20 20 20 20 20 28 6c 65 soc))). (le
1130: 74 2a 20 28 28 64 61 74 20 20 20 20 28 64 62 3a t* ((dat (db:
1140: 73 74 72 69 6e 67 2d 3e 6f 62 6a 20 6d 73 67 2d string->obj msg-
1150: 69 6e 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 6e in transport: 'n
1160: 6d 73 67 29 29 29 0a 09 28 64 65 62 75 67 3a 70 msg)))..(debug:p
1170: 72 69 6e 74 20 30 20 22 73 65 72 76 65 72 2c 20 rint 0 "server,
1180: 72 65 63 65 69 76 65 64 3a 20 22 20 64 61 74 29 received: " dat)
1190: 0a 09 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 ..(let ((result
11a0: 28 61 70 69 3a 65 78 65 63 75 74 65 2d 72 65 71 (api:execute-req
11b0: 75 65 73 74 73 20 64 62 73 74 72 75 63 74 20 64 uests dbstruct d
11c0: 61 74 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a at))).. (debug:
11d0: 70 72 69 6e 74 20 30 20 22 73 65 72 76 65 72 2c print 0 "server,
11e0: 20 73 65 6e 64 69 6e 67 3a 20 22 20 72 65 73 75 sending: " resu
11f0: 6c 74 29 0a 09 20 20 28 6e 6e 2d 73 65 6e 64 20 lt).. (nn-send
1200: 72 65 70 73 6f 63 20 28 64 62 3a 6f 62 6a 2d 3e repsoc (db:obj->
1210: 73 74 72 69 6e 67 20 72 65 73 75 6c 74 20 20 74 string result t
1220: 72 61 6e 73 70 6f 72 74 3a 20 27 6e 6d 73 67 29 ransport: 'nmsg)
1230: 29 29 0a 09 28 6c 6f 6f 70 20 28 6e 6e 2d 72 65 ))..(loop (nn-re
1240: 63 76 20 72 65 70 73 6f 63 29 29 29 29 29 29 0a cv repsoc)))))).
1250: 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 .;; all routes t
1260: 68 6f 75 67 68 20 68 65 72 65 20 65 6e 64 20 69 hough here end i
1270: 6e 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 28 64 n exit ....;;.(d
1280: 65 66 69 6e 65 20 28 6e 6d 73 67 2d 74 72 61 6e efine (nmsg-tran
1290: 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 72 75 6e sport:launch run
12a0: 2d 69 64 20 61 72 65 61 2d 64 61 74 29 0a 20 20 -id area-dat).
12b0: 28 6c 65 74 2a 20 28 28 74 64 62 64 61 74 20 20 (let* ((tdbdat
12c0: 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 (tasks:open-db
12d0: 61 72 65 61 2d 64 61 74 29 29 0a 09 20 28 64 62 area-dat)).. (db
12e0: 73 74 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 struct (db:setup
12f0: 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 68 6f 73 run-id)).. (hos
1300: 74 6e 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a tn (or (args:
1310: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
1320: 22 29 20 22 2d 22 29 29 29 0a 20 20 20 20 28 73 ") "-"))). (s
1330: 65 74 21 20 2a 72 75 6e 2d 69 64 2a 20 20 20 72 et! *run-id* r
1340: 75 6e 2d 69 64 29 0a 20 20 20 20 28 73 65 74 21 un-id). (set!
1350: 20 2a 69 6e 6d 65 6d 64 62 2a 20 64 62 73 74 72 *inmemdb* dbstr
1360: 75 63 74 29 0a 20 20 20 20 3b 3b 20 77 69 74 68 uct). ;; with
1370: 20 6e 62 66 61 6b 65 20 64 61 65 6d 6f 6e 69 7a nbfake daemoniz
1380: 65 20 69 73 6e 27 74 20 72 65 61 6c 6c 79 20 6e e isn't really n
1390: 65 65 64 65 64 0a 20 20 20 20 3b 3b 0a 20 20 20 eeded. ;;.
13a0: 20 3b 3b 20 28 69 66 20 28 61 72 67 73 3a 67 65 ;; (if (args:ge
13b0: 74 2d 61 72 67 20 22 2d 64 61 65 6d 6f 6e 69 7a t-arg "-daemoniz
13c0: 65 22 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 e"). ;; (
13d0: 62 65 67 69 6e 0a 20 20 20 20 3b 3b 20 20 20 20 begin. ;;
13e0: 20 20 20 28 64 61 65 6d 6f 6e 3a 69 7a 65 29 0a (daemon:ize).
13f0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 69 66 ;; (if
1400: 20 2a 61 6c 74 2d 6c 6f 67 2d 66 69 6c 65 2a 20 *alt-log-file*
1410: 3b 3b 20 77 65 20 73 68 6f 75 6c 64 20 72 65 2d ;; we should re-
1420: 63 6f 6e 6e 65 63 74 20 74 6f 20 74 68 69 73 20 connect to this
1430: 70 6f 72 74 2c 20 49 20 74 68 69 6e 6b 20 64 61 port, I think da
1440: 65 6d 6f 6e 3a 69 7a 65 20 64 69 73 72 75 70 74 emon:ize disrupt
1450: 73 20 69 74 0a 20 20 20 20 3b 3b 20 20 20 20 20 s it. ;;
1460: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
1470: 20 3b 3b 20 20 20 20 20 09 28 63 75 72 72 65 6e ;; .(curren
1480: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 20 2a 61 6c t-error-port *al
1490: 74 2d 6c 6f 67 2d 66 69 6c 65 2a 29 0a 20 20 20 t-log-file*).
14a0: 20 3b 3b 20 20 20 20 20 09 28 63 75 72 72 65 6e ;; .(curren
14b0: 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 2a 61 t-output-port *a
14c0: 6c 74 2d 6c 6f 67 2d 66 69 6c 65 2a 29 29 29 29 lt-log-file*))))
14d0: 29 0a 20 20 20 20 28 69 66 20 28 73 65 72 76 65 ). (if (serve
14e0: 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 r:check-if-runni
14f0: 6e 67 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 ng run-id area-d
1500: 61 74 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 at)..(begin.. (
1510: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1520: 20 30 20 22 53 65 72 76 65 72 20 66 6f 72 20 72 0 "Server for r
1530: 75 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 20 22 un-id " run-id "
1540: 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 already running
1550: 22 29 0a 09 20 20 28 65 78 69 74 20 30 29 29 29 ").. (exit 0)))
1560: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
1570: 28 73 65 72 76 65 72 2d 69 64 20 28 74 61 73 6b (server-id (task
1580: 73 3a 73 65 72 76 65 72 2d 6c 6f 63 6b 2d 73 6c s:server-lock-sl
1590: 6f 74 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d ot (db:delay-if-
15a0: 62 75 73 79 20 74 64 62 64 61 74 29 20 72 75 6e busy tdbdat) run
15b0: 2d 69 64 29 29 0a 09 20 20 20 20 20 20 20 28 72 -id)).. (r
15c0: 65 6d 74 72 69 65 73 20 20 34 29 29 0a 20 20 20 emtries 4)).
15d0: 20 20 20 28 69 66 20 28 6e 6f 74 20 73 65 72 76 (if (not serv
15e0: 65 72 2d 69 64 29 0a 09 20 20 28 69 66 20 28 3e er-id).. (if (>
15f0: 20 72 65 6d 74 72 69 65 73 20 30 29 0a 09 20 20 remtries 0)..
1600: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 74 68 (begin...(th
1610: 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 read-sleep! 2)..
1620: 09 28 69 66 20 28 6e 6f 74 20 28 73 65 72 76 65 .(if (not (serve
1630: 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 r:check-if-runni
1640: 6e 67 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 ng run-id area-d
1650: 61 74 29 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 at))... (loop
1660: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 6c (tasks:server-l
1670: 6f 63 6b 2d 73 6c 6f 74 20 28 64 62 3a 64 65 6c ock-slot (db:del
1680: 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 ay-if-busy tdbda
1690: 74 29 20 72 75 6e 2d 69 64 29 0a 09 09 09 20 20 t) run-id)....
16a0: 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 29 0a (- remtries 1)).
16b0: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 .. (begin...
16c0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
16d0: 74 2d 69 6e 66 6f 20 30 20 22 41 6e 6f 74 68 65 t-info 0 "Anothe
16e0: 72 20 73 65 72 76 65 72 20 74 6f 6f 6b 20 74 68 r server took th
16f0: 65 20 73 6c 6f 74 2c 20 65 78 69 74 69 6e 67 22 e slot, exiting"
1700: 29 0a 09 09 20 20 20 20 20 20 28 65 78 69 74 20 )... (exit
1710: 30 29 29 29 29 0a 09 20 20 20 20 20 20 28 62 65 0)))).. (be
1720: 67 69 6e 0a 09 09 3b 3b 20 73 69 6e 63 65 20 77 gin...;; since w
1730: 65 20 64 69 64 6e 27 74 20 67 65 74 20 74 68 65 e didn't get the
1740: 20 73 65 72 76 65 72 20 6c 6f 63 6b 20 77 65 20 server lock we
1750: 61 72 65 20 67 6f 69 6e 67 20 74 6f 20 63 6c 65 are going to cle
1760: 61 6e 20 75 70 20 61 6e 64 20 62 61 69 6c 20 6f an up and bail o
1770: 75 74 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e ut...(debug:prin
1780: 74 2d 69 6e 66 6f 20 32 20 22 49 4e 46 4f 3a 20 t-info 2 "INFO:
1790: 73 65 72 76 65 72 20 70 69 64 3d 22 20 28 63 75 server pid=" (cu
17a0: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
17b0: 29 20 22 2c 20 68 6f 73 74 6e 61 6d 65 3d 22 20 ) ", hostname="
17c0: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 (get-host-name)
17d0: 22 20 6e 6f 74 20 73 74 61 72 74 69 6e 67 20 64 " not starting d
17e0: 75 65 20 74 6f 20 6f 74 68 65 72 20 63 61 6e 64 ue to other cand
17f0: 69 64 61 74 65 73 20 61 68 65 61 64 20 69 6e 20 idates ahead in
1800: 73 74 61 72 74 20 71 75 65 75 65 22 29 0a 09 09 start queue")...
1810: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 (tasks:server-de
1820: 6c 65 74 65 2d 72 65 63 6f 72 64 73 2d 66 6f 72 lete-records-for
1830: 2d 74 68 69 73 2d 70 69 64 20 28 64 62 3a 64 65 -this-pid (db:de
1840: 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 lay-if-busy tdbd
1850: 61 74 29 20 22 20 68 74 74 70 2d 74 72 61 6e 73 at) " http-trans
1860: 70 6f 72 74 3a 6c 61 75 6e 63 68 22 29 0a 09 09 port:launch")...
1870: 29 29 0a 09 20 20 3b 3b 20 6c 6f 63 6b 65 64 20 )).. ;; locked
1880: 69 6e 20 61 20 73 65 72 76 65 72 20 69 64 2c 20 in a server id,
1890: 74 72 79 20 74 6f 20 73 74 61 72 74 20 75 70 0a try to start up.
18a0: 09 20 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f . (nmsg-transpo
18b0: 72 74 3a 72 75 6e 20 64 62 73 74 72 75 63 74 20 rt:run dbstruct
18c0: 61 72 65 61 2d 64 61 74 20 68 6f 73 74 6e 20 72 area-dat hostn r
18d0: 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 69 64 29 un-id server-id)
18e0: 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 ). (set! *d
18f0: 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 idsomething* #t)
1900: 0a 20 20 20 20 20 20 28 65 78 69 74 29 29 29 29 . (exit))))
1910: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
1920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 ==========.;; S
1960: 45 20 52 20 56 20 45 20 52 20 20 20 55 20 54 20 E R V E R U T
1970: 49 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a 3b I L I T I E S .;
1980: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19c0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
19d0: 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 (nmsg-transport
19e0: 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 :mk-signature).
19f0: 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 (message-digest
1a00: 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 -string (md5-pri
1a10: 6d 69 74 69 76 65 29 20 0a 09 09 09 20 28 77 69 mitive) .... (wi
1a20: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 th-output-to-str
1a30: 69 6e 67 0a 09 09 09 20 20 20 28 6c 61 6d 62 64 ing.... (lambd
1a40: 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 77 72 a ().... (wr
1a50: 69 74 65 20 28 6c 69 73 74 20 28 63 75 72 72 65 ite (list (curre
1a60: 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 09 nt-directory)...
1a70: 09 09 09 20 20 28 61 72 67 76 29 29 29 29 29 29 ... (argv))))))
1a80: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
1a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 ===========.;; C
1ad0: 20 4c 20 49 20 45 20 4e 20 54 20 53 0a 3b 3b 3d L I E N T S.;;=
1ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b20: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 70 69 6e 67 20 74 =====..;; ping t
1b30: 68 65 20 73 65 72 76 65 72 20 61 74 20 68 6f 73 he server at hos
1b40: 74 3a 70 6f 72 74 0a 3b 3b 20 20 20 72 65 74 75 t:port.;; retu
1b50: 72 6e 20 74 68 65 20 6f 70 65 6e 20 73 6f 63 6b rn the open sock
1b60: 65 74 20 69 66 20 73 75 63 63 65 73 73 66 75 6c et if successful
1b70: 20 28 72 65 74 75 72 6e 2d 73 6f 63 6b 65 74 20 (return-socket
1b80: 3d 3d 20 23 74 29 0a 3b 3b 20 20 20 65 78 70 65 == #t).;; expe
1b90: 63 74 20 74 68 65 20 6b 65 79 20 65 78 70 65 63 ct the key expec
1ba0: 74 65 64 2d 6b 65 79 20 72 65 74 75 72 6e 65 64 ted-key returned
1bb0: 20 69 6e 20 70 61 79 6c 6f 61 64 0a 3b 3b 20 20 in payload.;;
1bc0: 20 73 65 6e 64 20 6f 75 72 2d 6b 65 79 20 6f 72 send our-key or
1bd0: 20 23 66 20 61 73 20 70 61 79 6c 6f 61 64 0a 3b #f as payload.;
1be0: 3b 0a 28 64 65 66 69 6e 65 20 28 6e 6d 73 67 2d ;.(define (nmsg-
1bf0: 74 72 61 6e 73 70 6f 72 74 3a 70 69 6e 67 20 68 transport:ping h
1c00: 6f 73 74 6e 20 70 6f 72 74 20 23 21 6b 65 79 20 ostn port #!key
1c10: 28 74 69 6d 65 6f 75 74 20 33 29 28 72 65 74 75 (timeout 3)(retu
1c20: 72 6e 2d 73 6f 63 6b 65 74 20 23 74 29 28 65 78 rn-socket #t)(ex
1c30: 70 65 63 74 65 64 2d 6b 65 79 20 23 66 29 28 6f pected-key #f)(o
1c40: 75 72 2d 6b 65 79 20 23 66 29 28 73 6f 63 6b 65 ur-key #f)(socke
1c50: 74 20 23 66 29 29 0a 20 20 3b 3b 20 73 65 6e 64 t #f)). ;; send
1c60: 20 61 20 72 61 6e 64 6f 6d 20 6e 75 6d 62 65 72 a random number
1c70: 20 61 6c 6f 6e 67 20 77 69 74 68 20 70 69 64 20 along with pid
1c80: 61 6e 64 20 63 68 65 63 6b 20 74 68 61 74 20 77 and check that w
1c90: 65 20 67 65 74 20 69 74 20 62 61 63 6b 0a 20 20 e get it back.
1ca0: 28 6c 65 74 2a 20 28 28 68 6f 73 74 20 20 20 20 (let* ((host
1cb0: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 68 6f 73 (if (or (not hos
1cc0: 74 6e 29 0a 09 09 09 20 20 28 65 71 75 61 6c 3f tn).... (equal?
1cd0: 20 68 6f 73 74 6e 20 22 2d 22 29 29 20 3b 3b 20 hostn "-")) ;;
1ce0: 75 73 65 20 6c 6f 63 61 6c 68 6f 73 74 0a 09 09 use localhost...
1cf0: 20 20 20 20 20 20 28 67 65 74 2d 68 6f 73 74 2d (get-host-
1d00: 6e 61 6d 65 29 0a 09 09 20 20 20 20 20 20 68 6f name)... ho
1d10: 73 74 6e 29 29 0a 09 20 28 72 65 71 20 20 20 20 stn)).. (req
1d20: 20 28 6f 72 20 73 6f 63 6b 65 74 0a 09 09 20 20 (or socket...
1d30: 20 20 20 20 28 6c 65 74 20 28 28 73 6f 63 20 28 (let ((soc (
1d40: 6e 6e 2d 73 6f 63 6b 65 74 20 27 72 65 71 29 29 nn-socket 'req))
1d50: 29 0a 09 09 09 28 6e 6e 2d 63 6f 6e 6e 65 63 74 )....(nn-connect
1d60: 20 73 6f 63 20 28 63 6f 6e 63 20 22 74 63 70 3a soc (conc "tcp:
1d70: 2f 2f 22 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 //" host ":" por
1d80: 74 29 29 0a 09 09 09 73 6f 63 29 29 29 0a 09 20 t))....soc)))..
1d90: 28 73 75 63 63 65 73 73 20 23 74 29 0a 09 20 28 (success #t).. (
1da0: 64 61 74 20 20 20 20 20 28 76 65 63 74 6f 72 20 dat (vector
1db0: 22 70 69 6e 67 22 20 6f 75 72 2d 6b 65 79 29 29 "ping" our-key))
1dc0: 0a 09 20 28 72 65 73 75 6c 74 20 20 28 63 6f 6e .. (result (con
1dd0: 64 69 74 69 6f 6e 2d 63 61 73 65 20 0a 09 09 20 dition-case ...
1de0: 20 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 (nmsg-transpor
1df0: 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e t:client-api-sen
1e00: 64 2d 72 65 63 65 69 76 65 2d 72 61 77 20 72 65 d-receive-raw re
1e10: 71 20 64 61 74 20 74 69 6d 65 6f 75 74 3a 20 74 q dat timeout: t
1e20: 69 6d 65 6f 75 74 29 0a 09 09 20 20 20 28 28 74 imeout)... ((t
1e30: 69 6d 65 6f 75 74 29 28 73 65 74 21 20 73 75 63 imeout)(set! suc
1e40: 63 65 73 73 20 23 66 29 20 23 66 29 29 29 0a 09 cess #f) #f)))..
1e50: 20 28 6b 65 79 20 20 20 20 20 28 69 66 20 73 75 (key (if su
1e60: 63 63 65 73 73 20 0a 09 09 20 20 20 20 20 20 28 ccess ... (
1e70: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 75 6c vector-ref resul
1e80: 74 20 31 29 0a 09 09 20 20 20 20 20 20 23 66 29 t 1)... #f)
1e90: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
1ea0: 69 6e 74 20 30 20 22 73 75 63 63 65 73 73 3d 22 int 0 "success="
1eb0: 20 73 75 63 63 65 73 73 20 22 2c 20 6b 65 79 3d success ", key=
1ec0: 22 20 6b 65 79 20 22 2c 20 65 78 70 65 63 74 65 " key ", expecte
1ed0: 64 2d 6b 65 79 3d 22 20 65 78 70 65 63 74 65 64 d-key=" expected
1ee0: 2d 6b 65 79 20 22 2c 20 65 71 75 61 6c 3f 20 22 -key ", equal? "
1ef0: 20 28 65 71 75 61 6c 3f 20 6b 65 79 20 65 78 70 (equal? key exp
1f00: 65 63 74 65 64 2d 6b 65 79 29 29 0a 20 20 20 20 ected-key)).
1f10: 28 69 66 20 28 61 6e 64 20 73 75 63 63 65 73 73 (if (and success
1f20: 0a 09 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 .. (or (not
1f30: 65 78 70 65 63 74 65 64 2d 6b 65 79 29 20 3b 3b expected-key) ;;
1f40: 20 6a 75 73 74 20 67 65 74 74 69 6e 67 20 61 20 just getting a
1f50: 72 65 70 6c 79 20 69 73 20 67 6f 6f 64 20 65 6e reply is good en
1f60: 6f 75 67 68 20 74 68 65 6e 0a 09 09 20 28 65 71 ough then... (eq
1f70: 75 61 6c 3f 20 6b 65 79 20 65 78 70 65 63 74 65 ual? key expecte
1f80: 64 2d 6b 65 79 29 29 29 0a 09 28 69 66 20 72 65 d-key)))..(if re
1f90: 74 75 72 6e 2d 73 6f 63 6b 65 74 0a 09 20 20 20 turn-socket..
1fa0: 20 72 65 71 0a 09 20 20 20 20 28 62 65 67 69 6e req.. (begin
1fb0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 .. (if (not
1fc0: 20 73 6f 63 6b 65 74 29 28 6e 6e 2d 63 6c 6f 73 socket)(nn-clos
1fd0: 65 20 72 65 71 29 29 20 3b 3b 20 64 6f 6e 27 74 e req)) ;; don't
1fe0: 20 77 61 6e 74 20 61 20 73 69 64 65 20 65 66 66 want a side eff
1ff0: 65 63 74 20 6f 66 20 63 6c 6f 73 69 6e 67 20 73 ect of closing s
2000: 6f 63 6b 65 74 20 69 66 20 68 61 6e 64 65 64 20 ocket if handed
2010: 69 74 0a 09 20 20 20 20 20 20 23 74 29 29 0a 09 it.. #t))..
2020: 28 62 65 67 69 6e 0a 09 20 20 28 69 66 20 28 6e (begin.. (if (n
2030: 6f 74 20 73 6f 63 6b 65 74 29 28 6e 6e 2d 63 6c ot socket)(nn-cl
2040: 6f 73 65 20 72 65 71 29 29 20 3b 3b 20 66 61 69 ose req)) ;; fai
2050: 6c 65 64 20 74 6f 20 70 69 6e 67 2c 20 63 6c 6f led to ping, clo
2060: 73 65 20 73 6f 63 6b 65 74 20 61 73 20 73 69 64 se socket as sid
2070: 65 20 65 66 66 65 63 74 0a 09 20 20 23 66 29 29 e effect.. #f))
2080: 29 29 0a 0a 3b 3b 20 73 65 6e 64 20 64 61 74 61 ))..;; send data
2090: 20 74 6f 20 73 65 72 76 65 72 2c 20 77 61 69 74 to server, wait
20a0: 20 6d 61 78 20 6f 66 20 74 69 6d 65 6f 75 74 20 max of timeout
20b0: 73 65 63 6f 6e 64 73 20 66 6f 72 20 61 20 72 65 seconds for a re
20c0: 73 70 6f 6e 73 65 2e 0a 3b 3b 20 72 65 74 75 72 sponse..;; retur
20d0: 6e 20 23 28 20 73 75 63 63 65 73 73 2f 66 61 69 n #( success/fai
20e0: 6c 20 72 65 73 75 6c 74 20 29 0a 3b 3b 0a 3b 3b l result ).;;.;;
20f0: 20 66 6f 72 20 65 66 66 69 65 6e 63 79 20 69 74 for effiency it
2100: 20 69 73 20 65 61 73 69 65 72 20 74 6f 20 64 6f is easier to do
2110: 20 74 68 65 20 6f 62 6a 2d 3e 73 74 72 69 6e 67 the obj->string
2120: 20 61 6e 64 20 73 74 72 69 6e 67 2d 3e 6f 62 6a and string->obj
2130: 20 68 65 72 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e here..;;.(defin
2140: 65 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 e (nmsg-transpor
2150: 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e t:client-api-sen
2160: 64 2d 72 65 63 65 69 76 65 2d 72 61 77 20 73 6f d-receive-raw so
2170: 63 72 65 71 20 69 6e 64 61 74 20 23 21 6b 65 79 creq indat #!key
2180: 20 28 65 6e 61 62 6c 65 2d 73 65 6e 64 20 23 74 (enable-send #t
2190: 29 28 74 69 6d 65 6f 75 74 20 32 35 29 29 0a 20 )(timeout 25)).
21a0: 20 28 6c 65 74 2a 20 28 28 73 75 63 63 65 73 73 (let* ((success
21b0: 20 20 20 20 20 23 66 29 0a 09 20 28 72 65 73 75 #f).. (resu
21c0: 6c 74 20 20 20 20 20 20 23 66 29 0a 09 20 28 6b lt #f).. (k
21d0: 65 65 70 77 61 69 74 69 6e 67 20 23 74 29 0a 09 eepwaiting #t)..
21e0: 20 28 64 61 74 20 20 20 20 20 20 20 20 20 28 64 (dat (d
21f0: 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 69 6e b:obj->string in
2200: 64 61 74 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 dat transport: '
2210: 6e 6d 73 67 29 29 0a 09 20 28 73 65 6e 64 2d 72 nmsg)).. (send-r
2220: 65 63 76 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 ecv (make-thre
2230: 61 64 0a 09 09 20 20 20 20 20 20 20 28 6c 61 6d ad... (lam
2240: 62 64 61 20 28 29 0a 09 09 09 20 28 6e 6e 2d 73 bda ().... (nn-s
2250: 65 6e 64 20 73 6f 63 72 65 71 20 64 61 74 29 0a end socreq dat).
2260: 09 09 09 20 28 6c 65 74 2a 20 28 28 72 65 73 20 ... (let* ((res
2270: 28 6e 6e 2d 72 65 63 76 20 73 6f 63 72 65 71 29 (nn-recv socreq)
2280: 29 29 0a 09 09 09 20 20 20 28 73 65 74 21 20 73 )).... (set! s
2290: 75 63 63 65 73 73 20 23 74 29 0a 09 09 09 20 20 uccess #t)....
22a0: 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 64 (set! result (d
22b0: 62 3a 73 74 72 69 6e 67 2d 3e 6f 62 6a 20 72 65 b:string->obj re
22c0: 73 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 6e 6d s transport: 'nm
22d0: 73 67 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 sg))))...
22e0: 22 73 65 6e 64 2d 72 65 63 76 22 29 29 0a 09 20 "send-recv"))..
22f0: 28 74 69 6d 65 6f 75 74 20 20 20 20 20 28 6d 61 (timeout (ma
2300: 6b 65 2d 74 68 72 65 61 64 0a 09 09 20 20 20 20 ke-thread...
2310: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
2320: 09 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6f . (let loop ((co
2330: 75 6e 74 20 30 29 29 0a 09 09 09 20 20 20 28 74 unt 0)).... (t
2340: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
2350: 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
2360: 6e 74 2d 69 6e 66 6f 20 31 20 22 73 65 6e 64 2d nt-info 1 "send-
2370: 72 65 63 65 69 76 65 2d 72 61 77 2c 20 73 74 69 receive-raw, sti
2380: 6c 6c 20 77 61 69 74 69 6e 67 20 61 66 74 65 72 ll waiting after
2390: 20 22 20 63 6f 75 6e 74 20 22 20 73 65 63 6f 6e " count " secon
23a0: 64 73 2e 2e 2e 22 29 0a 09 09 09 20 20 20 28 69 ds...").... (i
23b0: 66 20 28 61 6e 64 20 6b 65 65 70 77 61 69 74 69 f (and keepwaiti
23c0: 6e 67 20 28 3c 20 63 6f 75 6e 74 20 74 69 6d 65 ng (< count time
23d0: 6f 75 74 29 29 20 3b 3b 20 79 65 73 2c 20 74 68 out)) ;; yes, th
23e0: 69 73 20 69 73 20 76 65 72 79 20 61 70 72 6f 78 is is very aprox
23f0: 69 6d 61 74 65 0a 09 09 09 20 20 20 20 20 20 20 imate....
2400: 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 (loop (+ count 1
2410: 29 29 29 29 0a 09 09 09 20 28 69 66 20 6b 65 65 )))).... (if kee
2420: 70 77 61 69 74 69 6e 67 0a 09 09 09 20 20 20 20 pwaiting....
2430: 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 (begin....
2440: 20 20 28 70 72 69 6e 74 20 22 74 69 6d 65 6f 75 (print "timeou
2450: 74 20 77 61 69 74 69 6e 67 20 66 6f 72 20 70 69 t waiting for pi
2460: 6e 67 22 29 0a 09 09 09 20 20 20 20 20 20 20 28 ng").... (
2470: 74 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 thread-terminate
2480: 21 20 73 65 6e 64 2d 72 65 63 76 29 29 29 29 0a ! send-recv)))).
2490: 09 09 20 20 20 20 20 20 20 22 74 69 6d 65 6f 75 .. "timeou
24a0: 74 22 29 29 29 0a 20 20 20 20 3b 3b 20 72 65 70 t"))). ;; rep
24b0: 6c 61 63 65 20 77 69 74 68 20 63 6f 6e 64 69 74 lace with condit
24c0: 69 6f 6e 2d 63 61 73 65 3f 0a 20 20 20 20 28 68 ion-case?. (h
24d0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
24e0: 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 . exn. (
24f0: 73 65 74 21 20 72 65 73 75 6c 74 20 22 74 69 6d set! result "tim
2500: 65 6f 75 74 22 29 0a 20 20 20 20 20 28 74 68 72 eout"). (thr
2510: 65 61 64 2d 73 74 61 72 74 21 20 74 69 6d 65 6f ead-start! timeo
2520: 75 74 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 ut). (thread
2530: 2d 73 74 61 72 74 21 20 73 65 6e 64 2d 72 65 63 -start! send-rec
2540: 76 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 2d v). (thread-
2550: 6a 6f 69 6e 21 20 73 65 6e 64 2d 72 65 63 76 29 join! send-recv)
2560: 0a 20 20 20 20 20 28 69 66 20 73 75 63 63 65 73 . (if succes
2570: 73 20 28 74 68 72 65 61 64 2d 74 65 72 6d 69 6e s (thread-termin
2580: 61 74 65 21 20 74 69 6d 65 6f 75 74 29 29 29 0a ate! timeout))).
2590: 20 20 20 20 3b 3b 20 72 61 69 73 65 20 74 69 6d ;; raise tim
25a0: 65 6f 75 74 20 65 72 72 6f 72 20 69 66 20 74 69 eout error if ti
25b0: 6d 65 64 20 6f 75 74 0a 20 20 20 20 28 69 66 20 med out. (if
25c0: 73 75 63 63 65 73 73 0a 09 28 69 66 20 28 61 6e success..(if (an
25d0: 64 20 28 76 65 63 74 6f 72 3f 20 72 65 73 75 6c d (vector? resul
25e0: 74 29 0a 09 09 20 28 76 65 63 74 6f 72 2d 72 65 t)... (vector-re
25f0: 66 20 72 65 73 75 6c 74 20 30 29 29 20 3b 3b 20 f result 0)) ;;
2600: 64 69 64 20 69 74 20 66 61 69 6c 20 61 74 20 74 did it fail at t
2610: 68 65 20 73 65 72 76 65 72 3f 0a 09 20 20 20 20 he server?..
2620: 72 65 73 75 6c 74 20 20 20 20 20 20 20 20 20 20 result
2630: 20 20 20 20 20 20 3b 3b 20 6e 6f 70 65 2c 20 61 ;; nope, a
2640: 6c 6c 20 67 6f 6f 64 0a 09 20 20 20 20 28 62 65 ll good.. (be
2650: 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 gin.. (debu
2660: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
2670: 3a 20 65 72 72 6f 72 20 6f 63 63 75 72 65 64 20 : error occured
2680: 61 74 20 73 65 72 76 65 72 2c 20 69 6e 66 6f 3d at server, info=
2690: 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 " (vector-ref re
26a0: 73 75 6c 74 20 32 29 29 0a 09 20 20 20 20 20 20 sult 2))..
26b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
26c0: 20 63 6c 69 65 6e 74 20 63 61 6c 6c 20 63 68 61 client call cha
26d0: 69 6e 3a 22 29 0a 09 20 20 20 20 20 20 28 70 72 in:").. (pr
26e0: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 int-call-chain (
26f0: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
2700: 72 74 29 29 0a 09 20 20 20 20 20 20 28 64 65 62 rt)).. (deb
2710: 75 67 3a 70 72 69 6e 74 20 30 20 22 20 73 65 72 ug:print 0 " ser
2720: 76 65 72 20 63 61 6c 6c 20 63 68 61 69 6e 3a 22 ver call chain:"
2730: 29 0a 09 20 20 20 20 20 20 28 70 70 20 28 76 65 ).. (pp (ve
2740: 63 74 6f 72 2d 72 65 66 20 72 65 73 75 6c 74 20 ctor-ref result
2750: 31 29 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 1) (current-erro
2760: 72 2d 70 6f 72 74 29 29 0a 09 20 20 20 20 20 20 r-port))..
2770: 28 73 69 67 6e 61 6c 20 28 76 65 63 74 6f 72 2d (signal (vector-
2780: 72 65 66 20 72 65 73 75 6c 74 20 30 29 29 29 29 ref result 0))))
2790: 0a 09 28 73 69 67 6e 61 6c 20 28 6d 61 6b 65 2d ..(signal (make-
27a0: 63 6f 6d 70 6f 73 69 74 65 2d 63 6f 6e 64 69 74 composite-condit
27b0: 69 6f 6e 0a 09 09 20 28 6d 61 6b 65 2d 70 72 6f ion... (make-pro
27c0: 70 65 72 74 79 2d 63 6f 6e 64 69 74 69 6f 6e 20 perty-condition
27d0: 27 74 69 6d 65 6f 75 74 20 27 6d 65 73 73 61 67 'timeout 'messag
27e0: 65 20 22 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 e "nmsg-transpor
27f0: 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e t:client-api-sen
2800: 64 2d 72 65 63 65 69 76 65 2d 72 61 77 20 74 69 d-receive-raw ti
2810: 6d 65 64 20 6f 75 74 20 74 61 6c 6b 69 6e 67 20 med out talking
2820: 74 6f 20 73 65 72 76 65 72 22 29 29 29 29 29 29 to server"))))))
2830: 0a 0a 3b 3b 20 72 75 6e 20 6e 6d 73 67 2d 74 72 ..;; run nmsg-tr
2840: 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e ansport:keep-run
2850: 6e 69 6e 67 20 69 6e 20 61 20 70 61 72 61 6c 6c ning in a parall
2860: 65 6c 20 74 68 72 65 61 64 20 74 6f 20 6d 6f 6e el thread to mon
2870: 69 74 6f 72 20 74 68 61 74 20 74 68 65 20 64 62 itor that the db
2880: 20 69 73 20 62 65 69 6e 67 20 0a 3b 3b 20 75 73 is being .;; us
2890: 65 64 20 61 6e 64 20 74 6f 20 73 68 75 74 64 6f ed and to shutdo
28a0: 77 6e 20 61 66 74 65 72 20 73 6f 6d 65 74 69 6d wn after sometim
28b0: 65 20 69 66 20 69 74 20 69 73 20 6e 6f 74 2e 0a e if it is not..
28c0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6e 6d 73 67 ;;.(define (nmsg
28d0: 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d -transport:keep-
28e0: 72 75 6e 6e 69 6e 67 20 73 65 72 76 65 72 2d 69 running server-i
28f0: 64 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 d run-id area-da
2900: 74 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 t). ;; if none
2910: 72 75 6e 6e 69 6e 67 20 6f 72 20 69 66 20 3e 20 running or if >
2920: 32 30 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 seconds since
2930: 20 0a 20 20 3b 3b 20 73 65 72 76 65 72 20 6c 61 . ;; server la
2940: 73 74 20 75 73 65 64 20 74 68 65 6e 20 73 74 61 st used then sta
2950: 72 74 20 73 68 75 74 64 6f 77 6e 0a 20 20 3b 3b rt shutdown. ;;
2960: 20 54 68 69 73 20 74 68 72 65 61 64 20 77 61 69 This thread wai
2970: 74 73 20 66 6f 72 20 74 68 65 20 73 65 72 76 65 ts for the serve
2980: 72 20 74 6f 20 63 6f 6d 65 20 61 6c 69 76 65 0a r to come alive.
2990: 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 (let* ((server
29a0: 2d 69 6e 66 6f 20 28 6c 65 74 20 6c 6f 6f 70 20 -info (let loop
29b0: 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ().
29c0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
29d0: 28 28 73 64 61 74 20 23 66 29 29 0a 20 20 20 20 ((sdat #f)).
29e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29f0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 (mutex-loc
2a00: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
2a10: 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 tex*).
2a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a30: 28 73 65 74 21 20 73 64 61 74 20 2a 73 65 72 76 (set! sdat *serv
2a40: 65 72 2d 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 er-info*).
2a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a60: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
2a70: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
2a80: 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 tex*).
2a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2aa0: 28 69 66 20 73 64 61 74 20 0a 09 09 09 20 20 20 (if sdat ....
2ab0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 (begin.....(d
2ac0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2ad0: 30 20 22 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 0 "keep-running
2ae0: 67 6f 74 20 73 64 61 74 3d 22 20 73 64 61 74 29 got sdat=" sdat)
2af0: 0a 09 09 09 09 73 64 61 74 29 0a 20 20 20 20 20 .....sdat).
2b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b10: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
2b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b40: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
2b50: 2e 35 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 .5).
2b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b70: 20 20 20 20 28 6c 6f 6f 70 29 29 29 29 29 29 0a (loop)))))).
2b80: 20 20 20 20 20 20 20 20 20 28 69 66 61 63 65 20 (iface
2b90: 20 20 20 20 20 20 28 63 61 72 20 73 65 72 76 65 (car serve
2ba0: 72 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 r-info)).
2bb0: 20 20 28 70 6f 72 74 20 20 20 20 20 20 20 20 28 (port (
2bc0: 63 61 64 72 20 73 65 72 76 65 72 2d 69 6e 66 6f cadr server-info
2bd0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 61 73 )). (las
2be0: 74 2d 61 63 63 65 73 73 20 30 29 0a 09 20 28 74 t-access 0).. (t
2bf0: 64 62 64 61 74 20 20 20 20 20 20 28 74 61 73 6b dbdat (task
2c00: 73 3a 6f 70 65 6e 2d 64 62 20 61 72 65 61 2d 64 s:open-db area-d
2c10: 61 74 29 29 0a 09 20 28 73 65 72 76 65 72 2d 74 at)).. (server-t
2c20: 69 6d 65 6f 75 74 20 28 6c 65 74 20 28 28 74 6d imeout (let ((tm
2c30: 6f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 o (configf:looku
2c40: 70 20 20 28 6d 65 67 61 74 65 73 74 3a 61 72 65 p (megatest:are
2c50: 61 2d 63 6f 6e 66 69 67 64 61 74 20 61 72 65 61 a-configdat area
2c60: 2d 64 61 74 29 20 22 73 65 72 76 65 72 22 20 22 -dat) "server" "
2c70: 74 69 6d 65 6f 75 74 22 29 29 29 0a 09 09 09 20 timeout")))....
2c80: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
2c90: 6e 67 3f 20 74 6d 6f 29 0a 09 09 09 09 20 20 20 ng? tmo).....
2ca0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
2cb0: 20 74 6d 6f 29 29 0a 09 09 09 20 20 20 20 20 20 tmo))....
2cc0: 20 28 2a 20 36 30 20 36 30 20 28 73 74 72 69 6e (* 60 60 (strin
2cd0: 67 2d 3e 6e 75 6d 62 65 72 20 74 6d 6f 29 29 0a g->number tmo)).
2ce0: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 28 2a 20 ... ;; (*
2cf0: 33 20 32 34 20 36 30 20 36 30 29 20 3b 3b 20 64 3 24 60 60) ;; d
2d00: 65 66 61 75 6c 74 20 74 6f 20 74 68 72 65 65 20 efault to three
2d10: 64 61 79 73 0a 09 09 09 20 20 20 20 20 20 20 28 days.... (
2d20: 2a 20 36 30 20 31 29 20 20 20 20 20 20 20 20 20 * 60 1)
2d30: 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f 20 6f 6e ;; default to on
2d40: 65 20 6d 69 6e 75 74 65 0a 09 09 09 20 20 20 20 e minute....
2d50: 20 20 20 3b 3b 20 28 2a 20 36 30 20 36 30 20 32 ;; (* 60 60 2
2d60: 35 29 20 20 20 20 20 20 3b 3b 20 64 65 66 61 75 5) ;; defau
2d70: 6c 74 20 74 6f 20 32 35 20 68 6f 75 72 73 0a 09 lt to 25 hours..
2d80: 09 09 20 20 20 20 20 20 20 29 29 29 29 0a 20 20 .. )))).
2d90: 20 20 28 70 72 69 6e 74 20 22 4b 65 65 70 2d 72 (print "Keep-r
2da0: 75 6e 6e 69 6e 67 20 67 6f 74 20 73 65 72 76 65 unning got serve
2db0: 72 20 70 69 64 20 22 20 73 65 72 76 65 72 2d 69 r pid " server-i
2dc0: 64 20 22 2c 20 75 73 69 6e 67 20 69 66 61 63 65 d ", using iface
2dd0: 20 22 20 69 66 61 63 65 20 22 20 61 6e 64 20 70 " iface " and p
2de0: 6f 72 74 20 22 20 70 6f 72 74 29 0a 20 20 20 20 ort " port).
2df0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e (let loop ((coun
2e00: 74 20 30 29 29 0a 20 20 20 20 20 20 28 74 68 72 t 0)). (thr
2e10: 65 61 64 2d 73 6c 65 65 70 21 20 34 29 20 3b 3b ead-sleep! 4) ;;
2e20: 20 6e 6f 20 6e 65 65 64 20 74 6f 20 64 6f 20 74 no need to do t
2e30: 68 69 73 20 76 65 72 79 20 6f 66 74 65 6e 0a 20 his very often.
2e40: 20 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 73 79 6e ;; NB// syn
2e50: 63 20 63 75 72 72 65 6e 74 6c 79 20 64 6f 65 73 c currently does
2e60: 20 4e 4f 54 20 72 65 74 75 72 6e 20 71 75 65 75 NOT return queu
2e70: 65 2d 6c 65 6e 67 74 68 0a 20 20 20 20 20 20 28 e-length. (
2e80: 6c 65 74 20 28 29 20 3b 3b 20 28 71 75 65 75 65 let () ;; (queue
2e90: 2d 6c 65 6e 20 28 63 64 62 3a 63 6c 69 65 6e 74 -len (cdb:client
2ea0: 2d 63 61 6c 6c 20 73 65 72 76 65 72 2d 69 6e 66 -call server-inf
2eb0: 6f 20 27 73 79 6e 63 20 23 74 20 31 29 29 29 0a o 'sync #t 1))).
2ec0: 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ;; (print
2ed0: 22 53 65 72 76 65 72 20 72 75 6e 6e 69 6e 67 2c "Server running,
2ee0: 20 63 6f 75 6e 74 20 69 73 20 22 20 63 6f 75 6e count is " coun
2ef0: 74 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 t). (if (
2f00: 3c 20 63 6f 75 6e 74 20 31 29 20 3b 3b 20 33 78 < count 1) ;; 3x
2f10: 33 20 3d 20 39 20 73 65 63 73 20 61 70 72 6f 78 3 = 9 secs aprox
2f20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f . (lo
2f30: 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 op (+ count 1)))
2f40: 0a 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 . .
2f50: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
2f60: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
2f70: 29 0a 20 20 20 20 20 20 20 20 28 73 65 74 21 20 ). (set!
2f80: 6c 61 73 74 2d 61 63 63 65 73 73 20 2a 6c 61 73 last-access *las
2f90: 74 2d 64 62 2d 61 63 63 65 73 73 2a 29 0a 20 20 t-db-access*).
2fa0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
2fb0: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
2fc0: 6d 75 74 65 78 2a 29 0a 09 28 64 62 3a 73 79 6e mutex*)..(db:syn
2fd0: 63 2d 74 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d c-touched *inmem
2fe0: 64 62 2a 20 72 75 6e 2d 69 64 20 66 6f 72 63 65 db* run-id force
2ff0: 2d 73 79 6e 63 3a 20 23 74 29 0a 20 20 20 20 20 -sync: #t).
3000: 20 20 20 28 69 66 20 28 61 6e 64 20 2a 73 65 72 (if (and *ser
3010: 76 65 72 2d 72 75 6e 2a 0a 09 20 20 20 20 20 20 ver-run*..
3020: 20 28 3e 20 28 2b 20 6c 61 73 74 2d 61 63 63 65 (> (+ last-acce
3030: 73 73 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 ss server-timeou
3040: 74 29 0a 09 09 20 20 28 63 75 72 72 65 6e 74 2d t)... (current-
3050: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 seconds))).
3060: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
3070: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
3080: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
3090: 22 53 65 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 "Server continui
30a0: 6e 67 2c 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 ng, seconds sinc
30b0: 65 20 6c 61 73 74 20 64 62 20 61 63 63 65 73 73 e last db access
30c0: 3a 20 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d : " (- (current-
30d0: 73 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 seconds) last-ac
30e0: 63 65 73 73 29 29 0a 20 20 20 20 20 20 20 20 20 cess)).
30f0: 20 20 20 20 20 28 6c 6f 6f 70 20 30 29 29 0a 20 (loop 0)).
3100: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
3110: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
3120: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
3130: 6f 20 30 20 22 53 74 61 72 74 69 6e 67 20 74 6f o 0 "Starting to
3140: 20 73 68 75 74 64 6f 77 6e 20 74 68 65 20 73 65 shutdown the se
3150: 72 76 65 72 2e 22 29 0a 20 20 20 20 20 20 20 20 rver.").
3160: 20 20 20 20 20 20 28 73 65 74 21 20 2a 74 69 6d (set! *tim
3170: 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 09 e-to-exit* #t)..
3180: 20 20 20 20 20 20 28 64 62 3a 73 79 6e 63 2d 74 (db:sync-t
3190: 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d 64 62 2a ouched *inmemdb*
31a0: 20 72 75 6e 2d 69 64 20 66 6f 72 63 65 2d 73 79 run-id force-sy
31b0: 6e 63 3a 20 23 74 29 0a 20 20 20 20 20 20 20 20 nc: #t).
31c0: 20 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 (tasks:ser
31d0: 76 65 72 2d 64 65 6c 65 74 65 2d 72 65 63 6f 72 ver-delete-recor
31e0: 64 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 d (db:delay-if-b
31f0: 75 73 79 20 74 64 62 64 61 74 29 20 73 65 72 76 usy tdbdat) serv
3200: 65 72 2d 69 64 20 22 20 68 74 74 70 2d 74 72 61 er-id " http-tra
3210: 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e nsport:keep-runn
3220: 69 6e 67 22 29 0a 20 20 20 20 20 20 20 20 20 20 ing").
3230: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3240: 2d 69 6e 66 6f 20 30 20 22 53 65 72 76 65 72 20 -info 0 "Server
3250: 73 68 75 74 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 shutdown complet
3260: 65 2e 20 45 78 69 74 69 6e 67 22 29 0a 20 20 20 e. Exiting").
3270: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 (exit
3280: 29 0a 09 20 20 20 20 20 20 29 29 29 29 29 29 0a ).. )))))).
3290: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
32a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4c =========.;; C L
32e0: 20 49 20 45 20 4e 20 54 20 53 0a 3b 3b 3d 3d 3d I E N T S.;;===
32f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3330: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6e 6d ===..(define (nm
3340: 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 sg-transport:cli
3350: 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 63 ent-connect ifac
3360: 65 20 70 6f 72 74 6e 75 6d 29 0a 20 20 28 6c 65 e portnum). (le
3370: 74 2a 20 28 28 72 65 71 73 6f 63 20 20 20 20 20 t* ((reqsoc
3380: 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 (nmsg-transport
3390: 3a 70 69 6e 67 20 69 66 61 63 65 20 70 6f 72 74 :ping iface port
33a0: 6e 75 6d 20 72 65 74 75 72 6e 2d 73 6f 63 6b 65 num return-socke
33b0: 74 3a 20 23 74 29 29 29 0a 20 20 20 20 28 76 65 t: #t))). (ve
33c0: 63 74 6f 72 20 69 66 61 63 65 20 70 6f 72 74 6e ctor iface portn
33d0: 75 6d 20 23 66 20 23 66 20 23 66 20 28 63 75 72 um #f #f #f (cur
33e0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 72 65 rent-seconds) re
33f0: 71 73 6f 63 29 29 29 0a 0a 3b 3b 20 72 65 74 75 qsoc)))..;; retu
3400: 72 6e 73 20 72 65 73 75 6c 74 2c 20 74 68 65 72 rns result, ther
3410: 65 20 69 73 20 6e 6f 20 73 75 63 65 73 73 2f 66 e is no sucess/f
3420: 61 69 6c 20 66 6c 61 67 20 2d 20 68 61 6e 64 6c ail flag - handl
3430: 65 64 20 76 69 61 20 65 78 63 70 65 63 74 69 6f ed via excpectio
3440: 6e 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6e ns.;;.(define (n
3450: 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c msg-transport:cl
3460: 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 ient-api-send-re
3470: 63 65 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e ceive run-id con
3480: 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 nection-info cmd
3490: 20 70 61 72 61 6d 20 23 21 6b 65 79 20 28 72 65 param #!key (re
34a0: 6d 74 72 69 65 73 20 35 29 29 0a 20 20 3b 3b 20 mtries 5)). ;;
34b0: 4e 42 2f 2f 20 49 6e 20 74 68 65 20 68 74 6d 6c NB// In the html
34c0: 20 76 65 72 73 69 6f 6e 20 6f 66 20 74 68 69 73 version of this
34d0: 20 72 6f 75 74 69 6e 65 20 74 68 65 72 65 20 69 routine there i
34e0: 73 20 61 20 63 61 6c 6c 20 74 6f 20 0a 20 20 3b s a call to . ;
34f0: 3b 20 20 20 20 20 20 74 61 73 6b 73 3a 6b 69 6c ; tasks:kil
3500: 6c 2d 73 65 72 76 65 72 2d 72 75 6e 2d 69 64 20 l-server-run-id
3510: 77 68 65 6e 20 74 68 65 72 65 20 69 73 20 61 6e when there is an
3520: 20 65 78 63 65 70 74 69 6f 6e 0a 20 20 28 6d 75 exception. (mu
3530: 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d tex-lock! *http-
3540: 6d 75 74 65 78 2a 29 0a 20 20 28 6c 65 74 2a 20 mutex*). (let*
3550: 28 28 70 61 63 6b 65 74 20 20 28 76 65 63 74 6f ((packet (vecto
3560: 72 20 63 6d 64 20 70 61 72 61 6d 29 29 0a 09 20 r cmd param))..
3570: 28 72 65 71 73 6f 63 20 20 28 68 74 74 70 2d 74 (reqsoc (http-t
3580: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
3590: 64 61 74 2d 67 65 74 2d 73 6f 63 6b 65 74 20 63 dat-get-socket c
35a0: 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 29 29 onnection-info))
35b0: 0a 09 20 28 72 65 73 20 20 20 20 20 28 6e 6d 73 .. (res (nms
35c0: 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 g-transport:clie
35d0: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
35e0: 69 76 65 2d 72 61 77 20 72 65 71 73 6f 63 20 70 ive-raw reqsoc p
35f0: 61 63 6b 65 74 29 29 29 0a 3b 3b 09 20 28 73 74 acket))).;;. (st
3600: 61 74 75 73 20 20 28 76 65 63 74 6f 72 2d 72 65 atus (vector-re
3610: 66 20 72 61 77 72 65 73 20 30 29 29 0a 3b 3b 09 f rawres 0)).;;.
3620: 20 28 72 65 73 75 6c 74 20 20 28 76 65 63 74 6f (result (vecto
3630: 72 2d 72 65 66 20 72 61 77 72 65 73 20 31 29 29 r-ref rawres 1))
3640: 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c ). (mutex-unl
3650: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
3660: 2a 29 0a 20 20 20 20 72 65 73 29 29 20 3b 3b 20 *). res)) ;;
3670: 28 76 65 63 74 6f 72 20 73 74 61 74 75 73 20 28 (vector status (
3680: 69 66 20 73 74 61 74 75 73 20 28 64 62 3a 73 74 if status (db:st
3690: 72 69 6e 67 2d 3e 6f 62 6a 20 72 65 73 75 6c 74 ring->obj result
36a0: 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 6e 6d 73 transport: 'nms
36b0: 67 29 20 72 65 73 75 6c 74 29 29 29 29 0a 09 0a g) result))))...
36c0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
36d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3700: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4a 20 55 20 ========.;; J U
3710: 4e 20 4b 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d N K .;;=========
3720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
3760: 3b 20 44 4f 20 4e 4f 54 20 55 53 45 0a 3b 3b 0a ; DO NOT USE.;;.
3770: 28 64 65 66 69 6e 65 20 28 6e 6d 73 67 2d 74 72 (define (nmsg-tr
3780: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 ansport:client-s
3790: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 ignal-handler si
37a0: 67 6e 75 6d 29 0a 20 20 28 68 61 6e 64 6c 65 2d gnum). (handle-
37b0: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 exceptions. ex
37c0: 6e 0a 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e n. (debug:prin
37d0: 74 20 22 20 2e 2e 2e 20 65 78 69 74 69 6e 67 20 t " ... exiting
37e0: 2e 2e 2e 22 29 0a 20 20 20 28 6c 65 74 20 28 28 ..."). (let ((
37f0: 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th1 (make-thread
3800: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
3810: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 2a 72 65 (if (not *re
3820: 63 65 69 76 65 64 2d 72 65 73 70 6f 6e 73 65 2a ceived-response*
3830: 29 0a 09 09 09 09 20 28 72 65 63 65 69 76 65 2d )..... (receive-
3840: 6d 65 73 73 61 67 65 2a 20 28 63 6f 6d 6d 6f 6e message* (common
3850: 3a 67 65 74 2d 72 65 6d 6f 74 65 20 72 65 6d 6f :get-remote remo
3860: 74 65 20 23 66 29 29 29 29 20 3b 3b 20 66 6c 75 te #f)))) ;; flu
3870: 73 68 20 6f 75 74 20 6c 61 73 74 20 63 61 6c 6c sh out last call
3880: 20 69 66 20 61 70 70 6c 69 63 61 62 6c 65 0a 09 if applicable..
3890: 09 09 20 20 20 22 65 61 74 20 72 65 73 70 6f 6e .. "eat respon
38a0: 73 65 22 29 29 0a 09 20 28 74 68 32 20 28 6d 61 se")).. (th2 (ma
38b0: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
38c0: 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 64 65 a ().... (de
38d0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
38e0: 4f 52 3a 20 52 65 63 65 69 76 65 64 20 5e 43 2c OR: Received ^C,
38f0: 20 61 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 attempting clea
3900: 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 n exit. Please b
3910: 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 e patient and wa
3920: 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 it a few seconds
3930: 20 62 65 66 6f 72 65 20 68 69 74 74 69 6e 67 20 before hitting
3940: 5e 43 20 61 67 61 69 6e 2e 22 29 0a 09 09 09 20 ^C again.")....
3950: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
3960: 70 21 20 33 29 20 3b 3b 20 67 69 76 65 20 74 68 p! 3) ;; give th
3970: 65 20 66 6c 75 73 68 20 74 68 72 65 65 20 73 65 e flush three se
3980: 63 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 73 conds to do it's
3990: 20 73 74 75 66 66 0a 09 09 09 20 20 20 20 20 28 stuff.... (
39a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 20 debug:print 0 "
39b0: 20 20 20 20 20 20 44 6f 6e 65 2e 22 29 0a 09 09 Done.")...
39c0: 09 20 20 20 20 20 28 65 78 69 74 20 34 29 29 0a . (exit 4)).
39d0: 09 09 09 20 20 20 22 65 78 69 74 20 6f 6e 20 5e ... "exit on ^
39e0: 43 20 74 69 6d 65 72 22 29 29 29 0a 20 20 20 20 C timer"))).
39f0: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
3a00: 74 68 32 29 0a 20 20 20 20 20 28 74 68 72 65 61 th2). (threa
3a10: 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 d-start! th1).
3a20: 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 (thread-join!
3a30: 20 74 68 32 29 29 29 29 0a 0a th2))))..