Artifact
f2ac4bfe5b36e30d250009f6000514123963e8ca:
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 73 70 69 66 66 79 20 75 72 69 2d 63 6f se spiffy uri-co
0200: 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 68 74 mmon intarweb ht
0210: 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 66 79 tp-client spiffy
0220: 2d 72 65 71 75 65 73 74 2d 76 61 72 73 29 0a 0a -request-vars)..
0230: 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 73 (declare (unit s
0240: 65 72 76 65 72 29 29 0a 0a 28 64 65 63 6c 61 72 erver))..(declar
0250: 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 e (uses common))
0260: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0270: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0280: 73 65 73 20 74 65 73 74 73 29 29 0a 28 64 65 63 ses tests)).(dec
0290: 6c 61 72 65 20 28 75 73 65 73 20 74 61 73 6b 73 lare (uses tasks
02a0: 29 29 20 3b 3b 20 74 61 73 6b 73 20 61 72 65 20 )) ;; tasks are
02b0: 77 68 65 72 65 20 73 74 75 66 66 20 69 73 20 6d where stuff is m
02c0: 61 69 6e 74 61 69 6e 65 64 20 61 62 6f 75 74 20 aintained about
02d0: 77 68 61 74 20 69 73 20 72 75 6e 6e 69 6e 67 2e what is running.
02e0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
02f0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 29 29 http-transport))
0300: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0310: 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a zmq-transport)).
0320: 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f .(include "commo
0330: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm").
0340: 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 (include "db_rec
0350: 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 64 65 66 ords.scm")..(def
0360: 69 6e 65 20 28 73 65 72 76 65 72 3a 6d 61 6b 65 ine (server:make
0370: 2d 73 65 72 76 65 72 2d 75 72 6c 20 68 6f 73 74 -server-url host
0380: 70 6f 72 74 29 0a 20 20 28 69 66 20 28 6e 6f 74 port). (if (not
0390: 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 20 20 20 hostport).
03a0: 20 23 66 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 #f. (conc
03b0: 22 68 74 74 70 3a 2f 2f 22 20 28 63 61 72 20 68 "http://" (car h
03c0: 6f 73 74 70 6f 72 74 29 20 22 3a 22 20 28 63 61 ostport) ":" (ca
03d0: 64 72 20 68 6f 73 74 70 6f 72 74 29 29 29 29 0a dr hostport)))).
03e0: 0a 28 64 65 66 69 6e 65 20 20 2a 73 65 72 76 65 .(define *serve
03f0: 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 2d 62 65 61 r-loop-heart-bea
0400: 74 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f t* (current-seco
0410: 6e 64 73 29 29 0a 28 64 65 66 69 6e 65 20 2a 68 nds)).(define *h
0420: 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 20 eartbeat-mutex*
0430: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b (make-mutex))..;
0440: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
0450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0480: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 =======.;; S E R
0490: 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d V E R.;;=======
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
04e0: 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 74 6f .;; Call this to
04f0: 20 73 74 61 72 74 20 74 68 65 20 61 63 74 75 61 start the actua
0500: 6c 20 73 65 72 76 65 72 0a 3b 3b 0a 0a 28 64 65 l server.;;..(de
0510: 66 69 6e 65 20 2a 64 62 3a 70 72 6f 63 65 73 73 fine *db:process
0520: 2d 71 75 65 75 65 2d 6d 75 74 65 78 2a 20 28 6d -queue-mutex* (m
0530: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 28 64 65 ake-mutex))..(de
0540: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 72 75 6e fine (server:run
0550: 20 68 6f 73 74 6e 29 0a 20 20 28 64 65 62 75 67 hostn). (debug
0560: 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 6d 70 :print 2 "Attemp
0570: 74 69 6e 67 20 74 6f 20 73 74 61 72 74 20 74 68 ting to start th
0580: 65 20 73 65 72 76 65 72 20 2e 2e 2e 22 29 0a 20 e server ...").
0590: 20 28 69 66 20 28 6e 6f 74 20 2a 74 6f 70 70 61 (if (not *toppa
05a0: 74 68 2a 29 0a 20 20 20 20 20 20 28 69 66 20 28 th*). (if (
05b0: 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 not (setup-for-r
05c0: 75 6e 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 un)).. (begin..
05d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
05e0: 20 30 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 0 "ERROR: canno
05f0: 74 20 66 69 6e 64 20 6d 65 67 61 74 65 73 74 2e t find megatest.
0600: 63 6f 6e 66 69 67 2c 20 63 61 6e 6e 6f 74 20 73 config, cannot s
0610: 74 61 72 74 20 73 65 72 76 65 72 2c 20 65 78 69 tart server, exi
0620: 74 69 6e 67 22 29 0a 09 20 20 20 20 28 65 78 69 ting").. (exi
0630: 74 29 29 29 29 0a 20 20 28 6c 65 74 2a 20 28 3b t)))). (let* (;
0640: 3b 20 28 69 66 61 63 65 20 20 20 20 20 20 20 20 ; (iface
0650: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f (if (string=?
0660: 20 22 2d 22 20 68 6f 73 74 6e 29 0a 09 20 3b 3b "-" hostn).. ;;
0670: 20 20 20 20 20 20 20 20 09 20 20 20 20 20 20 23 . #
0680: 66 20 3b 3b 20 28 67 65 74 2d 68 6f 73 74 2d 6e f ;; (get-host-n
0690: 61 6d 65 29 20 0a 09 20 3b 3b 20 20 20 20 20 20 ame) .. ;;
06a0: 20 20 09 20 20 20 20 20 20 68 6f 73 74 6e 29 29 . hostn))
06b0: 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 20 20 .. (db
06c0: 20 20 20 20 23 66 29 20 3b 3b 20 20 20 20 20 20 #f) ;;
06d0: 20 20 28 6f 70 65 6e 2d 64 62 29 29 20 3b 3b 20 (open-db)) ;;
06e0: 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 68 we don't want th
06f0: 65 20 73 65 72 76 65 72 20 74 6f 20 62 65 20 6f e server to be o
0700: 70 65 6e 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 pening and closi
0710: 6e 67 20 74 68 65 20 64 62 20 75 6e 6e 65 63 65 ng the db unnece
0720: 73 61 72 69 6c 79 0a 09 20 28 68 6f 73 74 6e 61 sarily.. (hostna
0730: 6d 65 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 me (get-h
0740: 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 ost-name)).. (ip
0750: 61 64 64 72 73 74 72 20 20 20 20 20 20 20 28 6c addrstr (l
0760: 65 74 20 28 28 69 70 73 74 72 20 28 69 66 20 28 et ((ipstr (if (
0770: 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 string=? "-" hos
0780: 74 6e 29 0a 09 09 09 09 09 20 20 20 28 73 74 72 tn)...... (str
0790: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
07a0: 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 (map number->str
07b0: 69 6e 67 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c ing (u8vector->l
07c0: 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 ist (hostname->i
07d0: 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 22 2e p hostname))) ".
07e0: 22 29 0a 09 09 09 09 09 20 20 20 23 66 29 29 29 ")...... #f)))
07f0: 0a 09 09 09 20 20 20 20 28 69 66 20 69 70 73 74 .... (if ipst
0800: 72 20 69 70 73 74 72 20 68 6f 73 74 6e 29 29 29 r ipstr hostn)))
0810: 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 29 29 29 0a ;; hostname))).
0820: 09 20 28 73 74 61 72 74 2d 70 6f 72 74 20 20 20 . (start-port
0830: 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 (if (args:get-a
0840: 72 67 20 22 2d 70 6f 72 74 22 29 0a 09 09 09 20 rg "-port")....
0850: 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 (string->numb
0860: 65 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 er (args:get-arg
0870: 20 22 2d 70 6f 72 74 22 29 29 0a 09 09 09 20 20 "-port"))....
0880: 20 20 28 2b 20 35 30 30 30 20 28 72 61 6e 64 6f (+ 5000 (rando
0890: 6d 20 31 30 30 31 29 29 29 29 0a 09 20 28 6c 69 m 1001)))).. (li
08a0: 6e 6b 2d 74 72 65 65 2d 70 61 74 68 20 28 63 6f nk-tree-path (co
08b0: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e nfig-lookup *con
08c0: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
08d0: 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a 20 20 "linktree"))).
08e0: 20 20 28 73 65 74 21 20 2a 63 61 63 68 65 2d 6f (set! *cache-o
08f0: 6e 2a 20 23 74 29 0a 20 20 20 20 28 72 6f 6f 74 n* #t). (root
0900: 2d 70 61 74 68 20 20 20 20 20 28 69 66 20 6c 69 -path (if li
0910: 6e 6b 2d 74 72 65 65 2d 70 61 74 68 20 0a 09 09 nk-tree-path ...
0920: 20 20 20 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 link-tree
0930: 2d 70 61 74 68 0a 09 09 20 20 20 20 20 20 20 28 -path... (
0940: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
0950: 79 29 29 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a y))) ;; WARNING:
0960: 20 53 45 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 SECURITY HOLE.
0970: 46 49 58 20 41 53 41 50 21 0a 0a 20 20 20 20 3b FIX ASAP!.. ;
0980: 3b 20 53 65 74 75 70 20 74 68 65 20 77 65 62 20 ; Setup the web
0990: 73 65 72 76 65 72 20 61 6e 64 20 61 20 2f 63 74 server and a /ct
09a0: 72 6c 20 69 6e 74 65 72 66 61 63 65 0a 20 20 20 rl interface.
09b0: 20 3b 3b 0a 20 20 20 20 28 76 68 6f 73 74 2d 6d ;;. (vhost-m
09c0: 61 70 20 60 28 28 28 2a 20 61 6e 79 29 20 2e 20 ap `(((* any) .
09d0: 2c 28 6c 61 6d 62 64 61 20 28 63 6f 6e 74 69 6e ,(lambda (contin
09e0: 75 65 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b ue).... ;;
09f0: 20 6f 70 65 6e 20 74 68 65 20 64 62 20 6f 6e 20 open the db on
0a00: 74 68 65 20 66 69 72 73 74 20 63 61 6c 6c 20 0a the first call .
0a10: 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 6e ... (if (n
0a20: 6f 74 20 64 62 29 28 73 65 74 21 20 64 62 20 28 ot db)(set! db (
0a30: 6f 70 65 6e 2d 64 62 29 29 29 0a 09 09 09 20 20 open-db)))....
0a40: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 24 20 20 (let* (($
0a50: 20 28 72 65 71 75 65 73 74 2d 76 61 72 73 20 73 (request-vars s
0a60: 6f 75 72 63 65 3a 20 27 62 6f 74 68 29 29 0a 09 ource: 'both))..
0a70: 09 09 09 20 20 20 20 20 20 28 64 61 74 20 28 24 ... (dat ($
0a80: 20 27 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 'dat)).....
0a90: 20 20 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 (res #f)).....
0aa0: 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 65 (cond..... ((e
0ab0: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
0ac0: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
0ad0: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
0ae0: 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 68 ...... '(/ "h
0af0: 65 79 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 ey"))..... (se
0b00: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
0b10: 3a 20 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 : "hey there!\n"
0b20: 0a 09 09 09 09 09 09 20 20 68 65 61 64 65 72 73 ....... headers
0b30: 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 : '((content-typ
0b40: 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 e text/plain))))
0b50: 0a 09 09 09 09 20 20 3b 3b 20 54 68 69 73 20 69 ..... ;; This i
0b60: 73 20 74 68 65 20 2f 63 74 72 6c 20 70 61 74 68 s the /ctrl path
0b70: 20 77 68 65 72 65 20 64 61 74 61 20 69 73 20 68 where data is h
0b80: 61 6e 64 65 64 20 74 6f 20 74 68 65 20 73 65 72 anded to the ser
0b90: 76 65 72 20 61 6e 64 0a 09 09 09 09 20 20 3b 3b ver and..... ;;
0ba0: 20 72 65 73 70 6f 6e 73 65 73 20 0a 09 09 09 09 responses .....
0bb0: 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d ((equal? (uri-
0bc0: 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 path (request-ur
0bd0: 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 i (current-reque
0be0: 73 74 29 29 29 0a 09 09 09 09 09 20 20 20 27 28 st)))...... '(
0bf0: 2f 20 22 63 74 72 6c 22 29 29 0a 09 09 09 09 20 / "ctrl")).....
0c00: 20 20 28 6c 65 74 2a 20 28 28 70 61 63 6b 65 74 (let* ((packet
0c10: 20 28 64 62 3a 73 74 72 69 6e 67 2d 3e 6f 62 6a (db:string->obj
0c20: 20 64 61 74 29 29 0a 09 09 09 09 09 20 20 28 71 dat))...... (q
0c30: 74 79 70 65 20 20 28 63 64 62 3a 70 61 63 6b 65 type (cdb:packe
0c40: 74 2d 67 65 74 2d 71 74 79 70 65 20 70 61 63 6b t-get-qtype pack
0c50: 65 74 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 et)))..... (
0c60: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
0c70: 20 31 32 20 22 73 65 72 76 65 72 3d 3e 20 72 65 12 "server=> re
0c80: 63 65 69 76 65 64 20 70 61 63 6b 65 74 3d 22 20 ceived packet="
0c90: 70 61 63 6b 65 74 29 0a 09 09 09 09 20 20 20 20 packet).....
0ca0: 20 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d 62 65 (if (not (membe
0cb0: 72 20 71 74 79 70 65 20 27 28 73 79 6e 63 20 70 r qtype '(sync p
0cc0: 69 6e 67 29 29 29 0a 09 09 09 09 09 20 28 62 65 ing)))...... (be
0cd0: 67 69 6e 0a 09 09 09 09 09 20 20 20 28 6d 75 74 gin...... (mut
0ce0: 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 ex-lock! *heartb
0cf0: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 09 eat-mutex*).....
0d00: 09 20 20 20 28 73 65 74 21 20 2a 6c 61 73 74 2d . (set! *last-
0d10: 64 62 2d 61 63 63 65 73 73 2a 20 28 63 75 72 72 db-access* (curr
0d20: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 ent-seconds))...
0d30: 09 09 09 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c ... (mutex-unl
0d40: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
0d50: 6d 75 74 65 78 2a 29 29 29 0a 09 09 09 09 20 20 mutex*))).....
0d60: 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 ;; (mutex-loc
0d70: 6b 21 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 k! *db:process-q
0d80: 75 65 75 65 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 ueue-mutex*) ;;
0d90: 74 72 79 69 6e 67 20 61 20 6d 75 74 65 78 0a 09 trying a mutex..
0da0: 09 09 09 20 20 20 20 20 3b 3b 20 28 73 65 74 21 ... ;; (set!
0db0: 20 72 65 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 res (open-run-c
0dc0: 6c 6f 73 65 20 64 62 3a 70 72 6f 63 65 73 73 2d lose db:process-
0dd0: 71 75 65 75 65 2d 69 74 65 6d 20 6f 70 65 6e 2d queue-item open-
0de0: 64 62 20 70 61 63 6b 65 74 29 29 0a 09 09 09 09 db packet)).....
0df0: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 (set! res (
0e00: 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 65 db:process-queue
0e10: 2d 69 74 65 6d 20 64 62 20 70 61 63 6b 65 74 29 -item db packet)
0e20: 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 28 6d )..... ;; (m
0e30: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 utex-unlock! *db
0e40: 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 65 2d 6d :process-queue-m
0e50: 75 74 65 78 2a 29 0a 09 09 09 09 20 20 20 20 20 utex*).....
0e60: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
0e70: 6f 20 31 31 20 22 52 65 74 75 72 6e 20 76 61 6c o 11 "Return val
0e80: 75 65 20 66 72 6f 6d 20 64 62 3a 70 72 6f 63 65 ue from db:proce
0e90: 73 73 2d 71 75 65 75 65 2d 69 74 65 6d 20 69 73 ss-queue-item is
0ea0: 20 22 20 72 65 73 29 0a 09 09 09 09 20 20 20 20 " res).....
0eb0: 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
0ec0: 62 6f 64 79 3a 20 28 63 6f 6e 63 20 22 3c 68 65 body: (conc "<he
0ed0: 61 64 3e 63 74 72 6c 20 64 61 74 61 3c 2f 68 65 ad>ctrl data</he
0ee0: 61 64 3e 5c 6e 3c 62 6f 64 79 3e 22 0a 09 09 09 ad>\n<body>"....
0ef0: 09 09 09 09 09 72 65 73 0a 09 09 09 09 09 09 09 .....res........
0f00: 09 22 3c 2f 62 6f 64 79 3e 22 29 0a 09 09 09 09 ."</body>").....
0f10: 09 09 20 20 20 20 68 65 61 64 65 72 73 3a 20 27 .. headers: '
0f20: 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 ((content-type t
0f30: 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 29 0a 09 ext/plain)))))..
0f40: 09 09 09 20 20 28 65 6c 73 65 20 28 63 6f 6e 74 ... (else (cont
0f50: 69 6e 75 65 29 29 29 29 29 29 29 29 0a 20 20 20 inue)))))))).
0f60: 20 28 73 65 72 76 65 72 3a 74 72 79 2d 73 74 61 (server:try-sta
0f70: 72 74 2d 73 65 72 76 65 72 20 69 70 61 64 64 72 rt-server ipaddr
0f80: 73 74 72 20 73 74 61 72 74 2d 70 6f 72 74 29 0a str start-port).
0f90: 20 20 20 20 3b 3b 20 6c 69 74 65 33 3a 66 69 6e ;; lite3:fin
0fa0: 61 6c 69 7a 65 21 20 64 62 29 29 29 0a 20 20 20 alize! db))).
0fb0: 20 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))...(define (s
0fc0: 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 erver:mk-signatu
0fd0: 72 65 29 0a 20 20 28 6d 65 73 73 61 67 65 2d 64 re). (message-d
0fe0: 69 67 65 73 74 2d 73 74 72 69 6e 67 20 28 6d 64 igest-string (md
0ff0: 35 2d 70 72 69 6d 69 74 69 76 65 29 20 0a 09 09 5-primitive) ...
1000: 09 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 . (with-output-t
1010: 6f 2d 73 74 72 69 6e 67 0a 09 09 09 20 20 20 28 o-string.... (
1020: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
1030: 20 20 28 77 72 69 74 65 20 28 6c 69 73 74 20 28 (write (list (
1040: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
1050: 79 29 0a 09 09 09 09 09 20 20 28 61 72 67 76 29 y)...... (argv)
1060: 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))))))..;;======
1070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b0: 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 20 .;; S E R V E R
10c0: 20 20 55 20 54 20 49 20 4c 20 49 20 54 20 49 20 U T I L I T I
10d0: 45 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d E S .;;=========
10e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
1120: 3b 20 57 68 65 6e 20 75 73 69 6e 67 20 7a 6d 71 ; When using zmq
1130: 20 74 68 69 73 20 77 6f 75 6c 64 20 73 65 6e 64 this would send
1140: 20 74 68 65 20 6d 65 73 73 61 67 65 20 62 61 63 the message bac
1150: 6b 20 28 74 77 6f 20 73 74 65 70 20 70 72 6f 63 k (two step proc
1160: 65 73 73 29 0a 3b 3b 20 77 69 74 68 20 73 70 69 ess).;; with spi
1170: 66 66 79 20 6f 72 20 72 70 63 20 74 68 69 73 20 ffy or rpc this
1180: 73 69 6d 70 6c 79 20 72 65 74 75 72 6e 73 20 74 simply returns t
1190: 68 65 20 72 65 74 75 72 6e 20 64 61 74 61 20 74 he return data t
11a0: 6f 20 62 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b o be returned.;;
11b0: 20 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 .(define (serve
11c0: 72 3a 72 65 70 6c 79 20 72 65 74 75 72 6e 2d 61 r:reply return-a
11d0: 64 64 72 20 71 75 65 72 79 2d 73 69 67 20 73 75 ddr query-sig su
11e0: 63 63 65 73 73 2f 66 61 69 6c 20 72 65 73 75 6c ccess/fail resul
11f0: 74 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e t). (debug:prin
1200: 74 2d 69 6e 66 6f 20 31 31 20 22 73 65 72 76 65 t-info 11 "serve
1210: 72 3a 72 65 70 6c 79 20 72 65 74 75 72 6e 2d 61 r:reply return-a
1220: 64 64 72 3d 22 20 72 65 74 75 72 6e 2d 61 64 64 ddr=" return-add
1230: 72 20 22 2c 20 72 65 73 75 6c 74 3d 22 20 72 65 r ", result=" re
1240: 73 75 6c 74 29 0a 20 20 3b 3b 20 28 73 65 6e 64 sult). ;; (send
1250: 2d 6d 65 73 73 61 67 65 20 70 75 62 73 6f 63 6b -message pubsock
1260: 20 74 61 72 67 65 74 20 73 65 6e 64 2d 6d 6f 72 target send-mor
1270: 65 3a 20 23 74 29 0a 20 20 3b 3b 20 28 73 65 6e e: #t). ;; (sen
1280: 64 2d 6d 65 73 73 61 67 65 20 70 75 62 73 6f 63 d-message pubsoc
1290: 6b 20 0a 20 20 28 63 61 73 65 20 2a 74 72 61 6e k . (case *tran
12a0: 73 70 6f 72 74 2d 74 79 70 65 2a 0a 20 20 20 20 sport-type*.
12b0: 28 28 66 73 29 20 72 65 73 75 6c 74 29 0a 20 20 ((fs) result).
12c0: 20 20 28 28 68 74 74 70 29 28 64 62 3a 6f 62 6a ((http)(db:obj
12d0: 2d 3e 73 74 72 69 6e 67 20 28 76 65 63 74 6f 72 ->string (vector
12e0: 20 73 75 63 63 65 73 73 2f 66 61 69 6c 20 71 75 success/fail qu
12f0: 65 72 79 2d 73 69 67 20 72 65 73 75 6c 74 29 29 ery-sig result))
1300: 29 0a 20 20 20 20 28 28 7a 6d 71 29 0a 20 20 20 ). ((zmq).
1310: 20 20 28 73 65 6e 64 2d 6d 65 73 73 61 67 65 20 (send-message
1320: 70 75 62 73 6f 63 6b 20 74 61 72 67 65 74 20 73 pubsock target s
1330: 65 6e 64 2d 6d 6f 72 65 3a 20 23 74 29 0a 20 20 end-more: #t).
1340: 20 20 20 28 73 65 6e 64 2d 6d 65 73 73 61 67 65 (send-message
1350: 20 70 75 62 73 6f 63 6b 20 28 64 62 3a 6f 62 6a pubsock (db:obj
1360: 2d 3e 73 74 72 69 6e 67 20 28 76 65 63 74 6f 72 ->string (vector
1370: 20 73 75 63 63 65 73 73 2f 66 61 69 6c 20 71 75 success/fail qu
1380: 65 72 79 2d 73 69 67 20 72 65 73 75 6c 74 29 29 ery-sig result))
1390: 29 29 0a 20 20 20 20 28 65 6c 73 65 20 0a 20 20 )). (else .
13a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
13b0: 30 20 22 45 52 52 4f 52 3a 20 75 6e 72 65 63 6f 0 "ERROR: unreco
13c0: 67 6e 69 73 65 64 20 74 72 61 6e 73 70 6f 72 74 gnised transport
13d0: 20 74 79 70 65 3a 20 22 20 2a 74 72 61 6e 73 70 type: " *transp
13e0: 6f 72 74 2d 74 79 70 65 2a 29 0a 20 20 20 20 20 ort-type*).
13f0: 72 65 73 75 6c 74 29 29 29 0a 0a 3b 3b 3d 3d 3d result)))..;;===
1400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1440: 3d 3d 3d 0a 3b 3b 20 43 20 4c 20 49 20 45 20 4e ===.;; C L I E N
1450: 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d T S.;;=========
1460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
14a0: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 define (server:g
14b0: 65 74 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 et-client-signat
14c0: 75 72 65 29 0a 20 20 28 69 66 20 2a 6d 79 2d 63 ure). (if *my-c
14d0: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature*
14e0: 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e *my-client-sign
14f0: 61 74 75 72 65 2a 0a 20 20 20 20 20 20 28 6c 65 ature*. (le
1500: 74 20 28 28 73 69 67 20 28 73 65 72 76 65 72 3a t ((sig (server:
1510: 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 29 29 0a mk-signature))).
1520: 09 28 73 65 74 21 20 2a 6d 79 2d 63 6c 69 65 6e .(set! *my-clien
1530: 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 73 69 67 t-signature* sig
1540: 29 0a 09 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 )..*my-client-si
1550: 67 6e 61 74 75 72 65 2a 29 29 29 0a 0a 28 64 65 gnature*)))..(de
1560: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 63 6c 69 fine (server:cli
1570: 65 6e 74 2d 6c 6f 67 69 6e 20 73 65 72 76 65 72 ent-login server
1580: 64 61 74 29 0a 20 20 28 63 64 62 3a 6c 6f 67 69 dat). (cdb:logi
1590: 6e 20 73 65 72 76 65 72 64 61 74 20 2a 74 6f 70 n serverdat *top
15a0: 70 61 74 68 2a 20 28 73 65 72 76 65 72 3a 67 65 path* (server:ge
15b0: 74 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 t-client-signatu
15c0: 72 65 29 29 29 0a 0a 3b 3b 20 4e 6f 74 20 63 75 re)))..;; Not cu
15d0: 72 72 65 6e 74 6c 79 20 75 73 65 64 21 20 42 75 rrently used! Bu
15e0: 74 2c 20 49 20 74 68 69 6e 6b 20 69 74 20 2a 73 t, I think it *s
15f0: 68 6f 75 6c 64 2a 20 62 65 20 75 73 65 64 21 21 hould* be used!!
1600: 21 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 !.(define (serve
1610: 72 3a 63 6c 69 65 6e 74 2d 6c 6f 67 6f 75 74 20 r:client-logout
1620: 73 65 72 76 65 72 64 61 74 29 0a 20 20 28 6c 65 serverdat). (le
1630: 74 20 28 28 6f 6b 20 28 61 6e 64 20 28 73 6f 63 t ((ok (and (soc
1640: 6b 65 74 3f 20 73 65 72 76 65 72 64 61 74 29 0a ket? serverdat).
1650: 09 09 20 28 63 64 62 3a 6c 6f 67 6f 75 74 20 73 .. (cdb:logout s
1660: 65 72 76 65 72 64 61 74 20 2a 74 6f 70 70 61 74 erverdat *toppat
1670: 68 2a 20 28 73 65 72 76 65 72 3a 67 65 74 2d 63 h* (server:get-c
1680: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 29 lient-signature)
1690: 29 29 29 29 0a 20 20 20 20 6f 6b 29 29 0a 0a 28 )))). ok))..(
16a0: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 63 define (server:c
16b0: 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 lient-connect if
16c0: 61 63 65 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 ace port). (let
16d0: 2a 20 28 28 6c 6f 67 69 6e 2d 72 65 73 20 20 20 * ((login-res
16e0: 23 66 29 0a 09 20 28 73 65 72 76 65 72 64 61 74 #f).. (serverdat
16f0: 20 20 20 28 6c 69 73 74 20 69 66 61 63 65 20 70 (list iface p
1700: 6f 72 74 29 29 29 0a 20 20 20 20 28 73 65 74 21 ort))). (set!
1710: 20 6c 6f 67 69 6e 2d 72 65 73 20 28 73 65 72 76 login-res (serv
1720: 65 72 3a 63 6c 69 65 6e 74 2d 6c 6f 67 69 6e 20 er:client-login
1730: 73 65 72 76 65 72 64 61 74 29 29 0a 20 20 20 20 serverdat)).
1740: 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e (if (and (not (n
1750: 75 6c 6c 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 29 ull? login-res))
1760: 0a 09 20 20 20 20 20 28 63 61 72 20 6c 6f 67 69 .. (car logi
1770: 6e 2d 72 65 73 29 29 0a 09 28 62 65 67 69 6e 0a n-res))..(begin.
1780: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
1790: 69 6e 66 6f 20 32 20 22 4c 6f 67 67 65 64 20 69 info 2 "Logged i
17a0: 6e 20 61 6e 64 20 63 6f 6e 6e 65 63 74 65 64 20 n and connected
17b0: 74 6f 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 to " iface ":" p
17c0: 6f 72 74 29 0a 09 20 20 28 73 65 74 21 20 2a 72 ort).. (set! *r
17d0: 75 6e 72 65 6d 6f 74 65 2a 20 73 65 72 76 65 72 unremote* server
17e0: 64 61 74 29 0a 09 20 20 73 65 72 76 65 72 64 61 dat).. serverda
17f0: 74 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 t)..(begin.. (d
1800: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1810: 32 20 22 46 61 69 6c 65 64 20 74 6f 20 6c 6f 67 2 "Failed to log
1820: 69 6e 20 6f 72 20 63 6f 6e 6e 65 63 74 20 74 6f in or connect to
1830: 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 " iface ":" por
1840: 74 29 0a 09 20 20 28 73 65 74 21 20 2a 72 75 6e t).. (set! *run
1850: 72 65 6d 6f 74 65 2a 20 23 66 29 0a 09 20 20 23 remote* #f).. #
1860: 66 29 29 29 29 0a 0a 3b 3b 20 44 6f 20 61 6c 6c f))))..;; Do all
1870: 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 the connection
1880: 77 6f 72 6b 2c 20 6c 6f 6f 6b 20 75 70 20 74 68 work, look up th
1890: 65 20 74 72 61 6e 73 70 6f 72 74 20 74 79 70 65 e transport type
18a0: 20 61 6e 64 20 73 65 74 20 75 70 20 74 68 65 0a and set up the.
18b0: 3b 3b 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 ;; connection if
18c0: 20 72 65 71 75 69 72 65 64 2e 0a 3b 3b 0a 28 64 required..;;.(d
18d0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 63 6c efine (server:cl
18e0: 69 65 6e 74 2d 73 65 74 75 70 20 23 21 6b 65 79 ient-setup #!key
18f0: 20 28 6e 75 6d 74 72 69 65 73 20 35 30 29 29 0a (numtries 50)).
1900: 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 6f 70 70 (if (not *topp
1910: 61 74 68 2a 29 0a 20 20 20 20 20 20 28 69 66 20 ath*). (if
1920: 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d (not (setup-for-
1930: 72 75 6e 29 29 0a 09 20 20 28 62 65 67 69 6e 0a run)).. (begin.
1940: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
1950: 74 20 30 20 22 45 52 52 4f 52 3a 20 66 61 69 6c t 0 "ERROR: fail
1960: 65 64 20 74 6f 20 66 69 6e 64 20 6d 65 67 61 74 ed to find megat
1970: 65 73 74 2e 63 6f 6e 66 69 67 2c 20 65 78 69 74 est.config, exit
1980: 69 6e 67 22 29 0a 09 20 20 20 20 28 65 78 69 74 ing").. (exit
1990: 29 29 29 29 0a 20 20 28 64 65 62 75 67 3a 70 72 )))). (debug:pr
19a0: 69 6e 74 2d 69 6e 66 6f 20 31 31 20 22 2a 74 72 int-info 11 "*tr
19b0: 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 69 73 ansport-type* is
19c0: 20 22 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 " *transport-ty
19d0: 70 65 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 pe*). (let* ((h
19e0: 6f 73 74 69 6e 66 6f 20 20 20 28 69 66 20 28 6e ostinfo (if (n
19f0: 6f 74 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 ot *transport-ty
1a00: 70 65 2a 29 20 3b 3b 20 49 66 20 77 65 20 64 6f pe*) ;; If we do
1a10: 6e 74 27 20 61 6c 72 65 61 64 79 20 68 61 76 65 nt' already have
1a20: 20 74 72 61 6e 73 70 6f 72 74 20 74 79 70 65 20 transport type
1a30: 73 65 74 20 74 68 65 6e 20 66 69 67 75 72 65 20 set then figure
1a40: 69 74 20 6f 75 74 0a 09 09 09 20 28 6f 70 65 6e it out.... (open
1a50: 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 -run-close tasks
1a60: 3a 67 65 74 2d 62 65 73 74 2d 73 65 72 76 65 72 :get-best-server
1a70: 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 0a tasks:open-db).
1a80: 09 09 09 20 23 66 29 29 29 0a 20 20 20 20 3b 3b ... #f))). ;;
1a90: 20 69 66 20 68 61 76 65 20 68 6f 73 74 69 6e 66 if have hostinf
1aa0: 6f 20 74 68 65 6e 20 65 78 74 72 61 63 74 20 74 o then extract t
1ab0: 68 65 20 74 72 61 6e 73 70 6f 72 74 20 74 79 70 he transport typ
1ac0: 65 20 0a 20 20 20 20 3b 3b 20 65 6c 73 65 20 66 e . ;; else f
1ad0: 61 6c 6c 20 62 61 63 6b 20 74 6f 20 66 73 0a 20 all back to fs.
1ae0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1af0: 69 6e 66 6f 20 31 31 20 22 43 4c 49 45 4e 54 20 info 11 "CLIENT
1b00: 53 45 54 55 50 2c 20 68 6f 73 74 69 6e 66 6f 3d SETUP, hostinfo=
1b10: 22 20 68 6f 73 74 69 6e 66 6f 29 0a 20 20 20 20 " hostinfo).
1b20: 28 73 65 74 21 20 2a 74 72 61 6e 73 70 6f 72 74 (set! *transport
1b30: 2d 74 79 70 65 2a 20 28 69 66 20 68 6f 73 74 69 -type* (if hosti
1b40: 6e 66 6f 20 0a 09 09 09 20 20 20 20 20 20 20 28 nfo .... (
1b50: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
1b60: 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 tasks:hostinfo-g
1b70: 65 74 2d 74 72 61 6e 73 70 6f 72 74 20 68 6f 73 et-transport hos
1b80: 74 69 6e 66 6f 29 29 0a 09 09 09 20 20 20 20 20 tinfo))....
1b90: 20 20 27 66 73 29 29 0a 20 20 20 20 28 64 65 62 'fs)). (deb
1ba0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
1bb0: 22 55 73 69 6e 67 20 74 72 61 6e 73 70 6f 72 74 "Using transport
1bc0: 20 74 79 70 65 20 6f 66 20 22 20 2a 74 72 61 6e type of " *tran
1bd0: 73 70 6f 72 74 2d 74 79 70 65 2a 20 28 69 66 20 sport-type* (if
1be0: 68 6f 73 74 69 6e 66 6f 20 28 63 6f 6e 63 20 22 hostinfo (conc "
1bf0: 20 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f 20 22 to connect to "
1c00: 20 68 6f 73 74 69 6e 66 6f 29 20 22 22 29 29 0a hostinfo) "")).
1c10: 20 20 20 20 28 63 61 73 65 20 2a 74 72 61 6e 73 (case *trans
1c20: 70 6f 72 74 2d 74 79 70 65 2a 20 0a 20 20 20 20 port-type* .
1c30: 28 28 66 73 29 28 69 66 20 28 6e 6f 74 20 2a 6d ((fs)(if (not *m
1c40: 65 67 61 74 65 73 74 2d 64 62 2a 29 28 73 65 74 egatest-db*)(set
1c50: 21 20 2a 6d 65 67 61 74 65 73 74 2d 64 62 2a 20 ! *megatest-db*
1c60: 28 6f 70 65 6e 2d 64 62 29 29 29 29 0a 20 20 20 (open-db)))).
1c70: 20 28 28 68 74 74 70 29 0a 20 20 20 20 20 28 68 ((http). (h
1c80: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
1c90: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 28 74 61 ient-connect (ta
1ca0: 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 sks:hostinfo-get
1cb0: 2d 69 6e 74 65 72 66 61 63 65 20 68 6f 73 74 69 -interface hosti
1cc0: 6e 66 6f 29 0a 09 09 09 09 20 20 20 20 28 74 61 nfo)..... (ta
1cd0: 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 sks:hostinfo-get
1ce0: 2d 70 6f 72 74 20 68 6f 73 74 69 6e 66 6f 29 29 -port hostinfo))
1cf0: 29 0a 20 20 20 20 28 28 7a 6d 71 29 0a 20 20 20 ). ((zmq).
1d00: 20 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 (zmq-transport
1d10: 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 :client-connect
1d20: 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d (tasks:hostinfo-
1d30: 67 65 74 2d 69 6e 74 65 72 66 61 63 65 20 68 6f get-interface ho
1d40: 73 74 69 6e 66 6f 29 0a 09 09 09 09 20 20 20 28 stinfo)..... (
1d50: 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 tasks:hostinfo-g
1d60: 65 74 2d 70 6f 72 74 20 20 20 20 20 20 68 6f 73 et-port hos
1d70: 74 69 6e 66 6f 29 0a 09 09 09 09 20 20 20 28 74 tinfo)..... (t
1d80: 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 asks:hostinfo-ge
1d90: 74 2d 70 75 62 70 6f 72 74 20 20 20 68 6f 73 74 t-pubport host
1da0: 69 6e 66 6f 29 29 29 0a 20 20 20 20 28 65 6c 73 info))). (els
1db0: 65 20 20 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f e ;; default to
1dc0: 20 66 73 0a 20 20 20 20 20 28 73 65 74 21 20 2a fs. (set! *
1dd0: 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 transport-type*
1de0: 27 66 73 29 0a 20 20 20 20 20 28 73 65 74 21 20 'fs). (set!
1df0: 2a 6d 65 67 61 74 65 73 74 2d 64 62 2a 20 20 20 *megatest-db*
1e00: 20 28 6f 70 65 6e 2d 64 62 29 29 29 29 29 29 0a (open-db)))))).
1e10: 0a 0a 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 ...;; all routes
1e20: 20 74 68 6f 75 67 68 20 68 65 72 65 20 65 6e 64 though here end
1e30: 20 69 6e 20 65 78 69 74 20 2e 2e 2e 0a 28 64 65 in exit ....(de
1e40: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 6c 61 75 fine (server:lau
1e50: 6e 63 68 20 74 72 61 6e 73 70 6f 72 74 29 0a 20 nch transport).
1e60: 20 28 69 66 20 28 6e 6f 74 20 2a 74 6f 70 70 61 (if (not *toppa
1e70: 74 68 2a 29 0a 20 20 20 20 20 20 28 69 66 20 28 th*). (if (
1e80: 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 not (setup-for-r
1e90: 75 6e 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 un)).. (begin..
1ea0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1eb0: 20 30 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 0 "ERROR: canno
1ec0: 74 20 66 69 6e 64 20 6d 65 67 61 74 65 73 74 2e t find megatest.
1ed0: 63 6f 6e 66 69 67 2c 20 65 78 69 74 69 6e 67 22 config, exiting"
1ee0: 29 0a 09 20 20 20 20 28 65 78 69 74 29 29 29 29 ).. (exit))))
1ef0: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
1f00: 69 6e 66 6f 20 32 20 22 53 74 61 72 74 69 6e 67 info 2 "Starting
1f10: 20 73 65 72 76 65 72 20 75 73 69 6e 67 20 22 20 server using "
1f20: 74 72 61 6e 73 70 6f 72 74 20 22 20 74 72 61 6e transport " tran
1f30: 73 70 6f 72 74 22 29 0a 20 20 28 73 65 74 21 20 sport"). (set!
1f40: 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a *transport-type*
1f50: 20 74 72 61 6e 73 70 6f 72 74 29 0a 20 20 28 63 transport). (c
1f60: 61 73 65 20 74 72 61 6e 73 70 6f 72 74 0a 20 20 ase transport.
1f70: 20 20 28 28 66 73 29 20 20 20 28 65 78 69 74 29 ((fs) (exit)
1f80: 29 20 3b 3b 20 74 68 65 72 65 20 69 73 20 6e 6f ) ;; there is no
1f90: 20 22 66 73 22 20 74 72 61 6e 73 70 6f 72 74 0a "fs" transport.
1fa0: 20 20 20 20 28 28 68 74 74 70 29 20 28 68 74 74 ((http) (htt
1fb0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e p-transport:laun
1fc0: 63 68 29 29 0a 20 20 20 20 28 28 7a 6d 71 29 20 ch)). ((zmq)
1fd0: 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a (zmq-transport:
1fe0: 6c 61 75 6e 63 68 29 29 0a 20 20 20 20 28 65 6c launch)). (el
1ff0: 73 65 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 se. (debug:p
2000: 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 75 rint "WARNING: u
2010: 6e 72 65 63 6f 67 6e 69 73 65 64 20 74 72 61 6e nrecognised tran
2020: 73 70 6f 72 74 20 22 20 74 72 61 6e 73 70 6f 72 sport " transpor
2030: 74 29 0a 20 20 20 20 20 28 65 78 69 74 29 29 29 t). (exit)))
2040: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 )..(define (serv
2050: 65 72 3a 63 6c 69 65 6e 74 2d 73 69 67 6e 61 6c er:client-signal
2060: 2d 68 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 -handler signum)
2070: 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
2080: 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 tions. exn.
2090: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 22 20 2e (debug:print " .
20a0: 2e 2e 20 65 78 69 74 69 6e 67 20 2e 2e 2e 22 29 .. exiting ...")
20b0: 0a 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 . (let ((th1 (
20c0: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
20d0: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 22 bda ().... "
20e0: 22 29 20 3b 3b 20 64 6f 20 6e 6f 74 68 69 6e 67 ") ;; do nothing
20f0: 20 66 6f 72 20 6e 6f 77 20 28 77 61 73 20 66 6c for now (was fl
2100: 75 73 68 20 6f 75 74 20 6c 61 73 74 20 63 61 6c ush out last cal
2110: 6c 20 69 66 20 61 70 70 6c 69 63 61 62 6c 65 29 l if applicable)
2120: 0a 09 09 09 20 20 20 22 65 61 74 20 72 65 73 70 .... "eat resp
2130: 6f 6e 73 65 22 29 29 0a 09 20 28 74 68 32 20 28 onse")).. (th2 (
2140: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
2150: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 bda ().... (
2160: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
2170: 52 52 4f 52 3a 20 52 65 63 65 69 76 65 64 20 5e RROR: Received ^
2180: 43 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 63 6c C, attempting cl
2190: 65 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 ean exit. Please
21a0: 20 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 be patient and
21b0: 77 61 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e wait a few secon
21c0: 64 73 20 62 65 66 6f 72 65 20 68 69 74 74 69 6e ds before hittin
21d0: 67 20 5e 43 20 61 67 61 69 6e 2e 22 29 0a 09 09 g ^C again.")...
21e0: 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c . (thread-sl
21f0: 65 65 70 21 20 31 29 20 3b 3b 20 67 69 76 65 20 eep! 1) ;; give
2200: 74 68 65 20 66 6c 75 73 68 20 6f 6e 65 20 73 65 the flush one se
2210: 63 6f 6e 64 20 74 6f 20 64 6f 20 69 74 27 73 20 cond to do it's
2220: 73 74 75 66 66 0a 09 09 09 20 20 20 20 20 28 64 stuff.... (d
2230: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 20 20 ebug:print 0 "
2240: 20 20 20 20 20 44 6f 6e 65 2e 22 29 0a 09 09 09 Done.")....
2250: 20 20 20 20 20 28 65 78 69 74 20 34 29 29 0a 09 (exit 4))..
2260: 09 09 20 20 20 22 65 78 69 74 20 6f 6e 20 5e 43 .. "exit on ^C
2270: 20 74 69 6d 65 72 22 29 29 29 0a 20 20 20 20 20 timer"))).
2280: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
2290: 68 32 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 h2). (thread
22a0: 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 20 -start! th1).
22b0: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join!
22c0: 74 68 32 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 th2))))..(define
22d0: 20 28 73 65 72 76 65 72 3a 63 6c 69 65 6e 74 2d (server:client-
22e0: 6c 61 75 6e 63 68 29 0a 20 20 28 73 65 74 2d 73 launch). (set-s
22f0: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 ignal-handler! s
2300: 69 67 6e 61 6c 2f 69 6e 74 20 73 65 72 76 65 72 ignal/int server
2310: 3a 63 6c 69 65 6e 74 2d 73 69 67 6e 61 6c 2d 68 :client-signal-h
2320: 61 6e 64 6c 65 72 29 0a 20 20 20 28 69 66 20 28 andler). (if (
2330: 73 65 72 76 65 72 3a 63 6c 69 65 6e 74 2d 73 65 server:client-se
2340: 74 75 70 29 0a 20 20 20 20 20 20 20 28 64 65 62 tup). (deb
2350: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2
2360: 22 63 6f 6e 6e 65 63 74 65 64 20 61 73 20 63 6c "connected as cl
2370: 69 65 6e 74 22 29 0a 20 20 20 20 20 20 20 28 62 ient"). (b
2380: 65 67 69 6e 0a 09 20 28 64 65 62 75 67 3a 70 72 egin.. (debug:pr
2390: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 int 0 "ERROR: Fa
23a0: 69 6c 65 64 20 74 6f 20 63 6f 6e 6e 65 63 74 20 iled to connect
23b0: 61 73 20 63 6c 69 65 6e 74 22 29 0a 09 20 28 65 as client").. (e
23c0: 78 69 74 29 29 29 29 0a 0a xit))))..